perm filename MUSY.FAI[MUS,LCS]4 blob
sn#105249 filedate 1974-05-31 generic text, type T, neo UTF8
00100 TITLE MUSIC
00200 ;;;****** AS OF JAN. 12, 1971 *********
00300 ; XGP INIT ADDED JAN 1974
00400 ↓T←1
00500 T1←2
00600 T2←3
00700 T3←4
00800 A←5
00900 B ←6
01000 C←7
01100 D←10
01200 E←11
01300 F←12
01400 H←14
01500 OSP←13
01600 ↓P←15
01700 ↓FL←17
01800 NACS←←5
01900 NFACS←←4
02000 INSXR←←NFACS-1
02100 SSPCF←←10
02200 SDFLG←←20
02300 SNUMF←←40
02400 FIXFLG←←1000
02500 FLTFLG←←2000
02600 DF←←400000
02700 NUMFLG←←FIXFLG+FLTFLG
02800 SSPC2F←←4000
02900
03000 RFLG←←0 ;$$$%%&%$###""##$%$$$$$
03100 DECLBIT←←400
03200 RVBT←←400
03300 PRVBT←←11
03400 MULBIT←←1
03500 ADDBIT←←2
03600 FOOBIT←←100
03700 INSBIT←←40
03800 UGBIT←←4000
03900 FPARBT←←200
04000
04100 SRACBT←←10000
04200 SIACBT←←20000
04300 GPBIT←←FOOBIT ;NOT I OR X.
04400 FUNBIT←←40000
04500 SWVBT←←100000 ;DO NOT CHANGE ! SEE GFUNC.
04600 VRBLBT←←200000
04700 ;; RELOCATION AND FIXUP BITS .
04800 .FXBTS←←1
04900 LFXBTS←←2
05000 VRELBT←←14+1
05100 RRELBT←←4+1
05200 IRELBT←←10+1
05300 ;; FLAGS (RIGHT HALF):
05400 CSBRBT←←1
05500 SFOOBT←←10
05600 USBRBT←←2
05700 GFUNCF←←4
05800 EXTFLG←←40
05900 ARRFLG←←20
06000 RVFLG←←100
06100 RESTART←←200
06200 ;FLAGS (LEFT HALF).
06300 ERRFLG←←1
06400 MINFLG←←2
06500 SNUMF1←←4
06600 NOSTAR←←10
06700 DTFLG←←20
06800 ;; PARAMETER DESCRIPTOR BITS:
06900 FAOPAR←←1
07000 FDPARB←←4
07100 FDPARC←←5
07200
07300 COFF←←1000 ;PI CHANNEL OFF.
07400 CON←←2000
07500 DACHN←←100 ;PI CHANNEL 1.
07600
07700 LRFXBT←←200000 ;LEFT HALF REPLACEMENT FIXUP BIT.
07800 RRFXBT←←100000 ;RIGHT HALF.
07900 SWAPBT←←40000 ;SWAPPED FIXUP.
08000
08100 ;;;;; 5/74 DEFINE IOWD (A,B) <XWD -A,B-1>
08200 OPDEF EXP [0]
08300 OPDEF FIX [XWD 247000,0] ;FOR PDP10 ONLY. REMOVE WITH DDT FOR PDP6
08400 OPDEF OUTCHR [XWD 51040,0]
08500
08600 BEGIN SAVER
08700 ; (INSERTED 11/3/69)
08800 ; TO DUMP CORE IMAGE
08900 ; CREATE A FILE OF THE CURRENT CORE IMAGE.
09000 ; PICK UP THE USER'S INPUT FILE NAME STORED
09100 ; IN DLK AND CREATE A FILE CALLED:
09200 ; "NAME.SAV"
09300 ; WHERE NAME IS THE INPUT FILE NAME.
09400 ;
09500 ; THE SWAP UU0 WILL BE USED WHICH CLOSES ALL
09600 ; ACTIVE DEVICES.
09700 ;
09800 ; ACCUMULATORS 0 AND T WILL BE CLOBBERED BY THIS
09900 ; ROUTINE. ALL OTHERS WILL BE SAVED AND RESTORED.
10000
10100 INTERNAL SAVER
10200
10300 ↑SAVER: 0
10400 MOVE 0,SCP ;BASE OF INPUT BUFFER
10500 HRRZ T,IBUF ;CURRENT BUFFER
10600 SUBI 0,-BUF1-1(T) ;DIFFERENCE
10700 MOVEM 0,PLIST+LPLIST-10
10800
10900 MOVEM 17,ACS+17 ;SAVE REGISTERS
11000 MOVEI 17,ACS
11100 BLT 17,ACS+16
11200
11300 SKIPN T,DLK ;INPUT FILE NAME
11400 MOVSI T,'SAV'
11500 MOVEM T,SWPTBL+1
11600
11700 MOVSI T,SWPTBL ;ADDR OF 5 WORD BLOCK IN LEFT PART OF T
11800 CALL T,[SIXBIT /SWAP/]
11900
12000 RETR: MOVE P,[XWD -10,PLIST+LPLIST-10] ;PICK UP ACCUM P
12100 MOVEI FL,RESTART ;RESTORE RESTART FLAG
12200 SOS RECCT ;BACK UP TO PREVIOUS INPUT RECORD.
12300 PUSHJ P,SETUP ;JUMP TO RESTORE FILES
12400 POP P,SCP
12500 MOVEI GO
12600 HRRM JOBSA
12700 MOVSI 17,ACS ;RESTORE REGISTERS
12800 BLT 17,17
12900 JRA 16,(16)
13000
13100 ACS: BLOCK 20 ;REGISTER SAVE AREA
13200 SWPTBL: SIXBIT /DSK/ ;DEVICE FOR SWAP
13300 0 ;FOR FILENAME
13400 SIXBIT /SAV/ ;FILENAME.SAV
13500 RETR ;CORE SIZE (0=USE WHAT YOU NEED)
13600 0 ;END OF LIST
13700
13800 BEND SAVER
00100 ;INPUT ROUTINE. CALL INITIALLY WITH PUSHJ P,SETUP
00200 ;WILL READIN DTA# AND FILE NAME. GET CHRS BY
00300 ;ILDB IBUF+1. NEXT BUFFER BY INPUT DT,0.
00400 ;;;EXTERNAL IFIX
00500 EXTERNAL SMPLS
00600 EXTERNAL READIN
00700
00800 TTY←←1
00900 DT←←2
01000 ADCHN←←3
01100 SETUP: CALL [SIXBIT /RESET/]
01200 SETUP1: INIT TTY,1
01300 SIXBIT /TTY/
01400 XWD TOB,TIB
01500 CALL [SIXBIT /EXIT/]; ERROR CONDITION
01600 MOVSI 400000
01700 ANDCAM TIBUF+1 ;MARK INPUT BUFFERS EMPTY.
01800 ANDCAM BUF1+1
01900 ANDCAM BUF2+1
02000 ANDCAM BUF3+1
02100 HRRI TIBUF+1 ;INIT. BUFFER POINTERS.
02200 MOVEM TIB
02300 HRRI TOBUF+1
02400 MOVEM TOB
02500 OUTPUT TTY,1; SEE THE HAPPY SYSTEM
02600 TRNE FL,RESTART ;ARE WE RESTARTINIG ?
02700 JRST SET4 ;YES.
02800 MOVEI IMS
02900 JSR TXTOUT; A LF/CR *
03000 INPUT TTY,0; THE DTA # AND NAME
03100 SETZM DNAM
03200 MOVE 2,[POINT 6,DNAM]
03300 MOVEI T2,6
03400 SET3: ILDB TIB+1
03500 CAIN ":"
03600 JRST SET4
03700 SUBI 40
03800 IDPB 2
03900 SOJG T2,SET3
04000 SET4: INIT DT,1
04100 DNAM: SIXBIT /DTA/
04200 XWD 0,IBUF ;NO OUPUT ON THIS DEVICE.
04300 JRST AER1
04400 MOVE [XWD 400000,BUF1+1] ;SET UP BUFFER
04500 MOVEM IBUF ;HEADER SO SYSTEM WILL USE OUR BUFFERS.
04600 MOVSI 700
04700 MOVEM SCP ;BYTE SIZE.
04800 SETZM DLK+3 ;TO READ FILES OFF DSK
04900 TRZE FL,RESTART
05000 JRST SETIN
05100 MOVEI T,1
05200 MOVEM T,RECCT
05300 MOVE T1,[POINT 6,DLK]
05400 SETZM DLK
05500 SETZM DLK+1
05600 MOVEI T2,12
00100 RIN: ILDB TIB+1; GET FILE NAME
00200 CAIN 15
00300 JRST SETIN
00400 CAIN "."; AN EXTENSION
00500 JRST SETEX
00600 SUBI 40
00700 IDPB T1
00800 SOJG T2,RIN
00900 JRST SETIN
01000 TIB: 0
01100 POINT 7,0,35
01200 0
01300 TOB: 0
01400 POINT 7,0,35
01500 0
01600 TIBUF: 0
01700 XWD 21,.
01800 BLOCK 22
01900 TOBUF: 0
02000 XWD 21,.
02100 BLOCK 22
02200 DLK: BLOCK 4
02300 IBUF: XWD 400000,BUF1+1; MAGIC TO KEEP SYSTEM
02400 SCP: POINT 7,0,35; HAPPY
02500 ICCNT: 0 ;BUFFER CHAR. COUNT.
02600 SETEX: TLZ T1,770000
02700 JRST RIN
02800 SETIN: LOOKUP DT,DLK; GET FILE SETUP
02900 JRST NER; NON-EX FILE
03000 PUSHJ P,RDBUF ;GET FIRST BUFFER
03100 MOVE BUF1+3 ;LINE NO. FIRST ?
03200 TRNE 1
03300 AOS SCP ;YES; ADVANCE SCP PAST IT.
03400 SETZM SNCHR
03500 SETZM FOONLY# ;BARF !!
03600 POPJ P,; DONE
03700 BUF1: 0
03800 XWD 201,BUF2+1
03900 BLOCK 202
04000 BUF2: 0
04100 XWD 201,BUF3+1
04200 BLOCK 202
04300 BUF3: 0
04400 XWD 201,BUF1+1
04500 BLOCK 202
00100 AER1: MOVEI DEV1MS; ERROR ROUTINE FOR NOT AVAILABLE
00200 JSR TXTOUT; DECTAPE
00300 MOVEI T1,4
00400 MOVEI DNAM
00500 PUSHJ P,SIXOUT
00600 MOVEI DEV2MS
00700 JSR TXTOUT
00800 JRST SETUP
00900 NER: MOVEI NAM1MS
01000 JSR TXTOUT
01100 MOVEI T1,6
01200 MOVEI DLK
01300 PUSHJ P,SIXOUT
01400 HLRZ DLK+1
01500 JUMPE NEX1
01600 MOVEI "."
01700 IDPB TOB+1
01800 MOVEI T1,3
01900 MOVEI DLK+1
02000 PUSHJ P,SIXOUT
02100 NEX1: MOVEI NAM2MS
02200 JSR TXTOUT
02300 JRST SETUP
02400 NAM1MS: ASCIZ /
02500 FILE /
02600 NAM2MS: ASCIZ / NOT FOUND
02700 /
02800
02900 DECPNT: PUSHJ P,DECPNN ;SPACE COMES AFTER NUM IS TYPED.
03000 MOVEI A,40
03100 SOSGE TOB+2
03200 OUTPUT TTY,0
03300 IDPB A,TOB+1
03400 POPJ P,
03500
03600
03700 DECPNN: IDIVI A,12 ;PRINT DECIMAL INTEGER FROM A.
03800 HRLM B,(P) ;SAVE LOW ORDER DIGIT.
03900 SKIPE A ;DONE ?
04000 PUSHJ P,DECPNN ;NO. RECUR FOR REST OF DIGITS.
04100 HLRZ A,(P) ;YES. GET HIGH ORDER DIGIT.
04200 ADDI A,"0" ;CONVERT TO ASCII.
04300 SOSGE TOB+2 ;OUTPUT IT.
04400 OUTPUT TTY,0
04500 IDPB A,TOB+1
04600 POPJ P, ;RETURN.
00100 SIXOUT: TLO 440600 ; MAKE BYTE POINTER
00200 LOOPTS: SOJL T1,[POPJ P,]
00300 ILDB T,0
00400 JUMPE T,[POPJ P,]
00500 ADDI T,40
00600 IDPB T,TOB+1
00700 JRST LOOPTS
00800 TXTOUT: 0
00900 TLO 440700; ANOTHER POINTER
01000 LPT1: ILDB T,0
01100 JUMPE T,RETPT
01200 SOSGE TOB+2
01300 OUTPUT TTY,0
01400 IDPB T,TOB+1
01500 JRST LPT1
01600 RETPT: OUTPUT TTY,0
01700 JRST @TXTOUT
01800 DEV1MS: ASCIZ /
01900 DEVICE /
02000 DEV2MS: ASCIZ / NOT AVAILABLE
02100 /
02200 IMS: ASCIZ /
02300 * INPUT ? /
02400
02500 RDBUF: MOVEI [BYTE (7)15,12,52] ;ASCIZ / CR LF */
02600 MOVSI A,'TTY'
02700 CAME A,DNAM ;IS INPUT DEVICE A TTY ?
02800 TLO FL,NOSTAR ;NO. SUPRESS THE *.
02900 TLZN FL,NOSTAR ;PRINT IF NOSTAR NOT ON.
03000 CALLI 3 ;YES. TYPE CR LF *.
03100 USETI DT,@RECCT# ;POSITION INPUT FILE TO RIGHT RECORD.
03200 AOS RECCT ;ADD 1 TO RECORD CTR
03300 INPUT DT,0 ;READ NEW INPUT BUFFER.
03400 STATZ DT,20000 ;END OF FILE SEEN ?
03500 JRST SETUP ;YES.
03600 MOVEI 4 ;MAKE SURE 0 WORD TERMINATES IT.
03700 ADD ICCNT ;CHAR. COUNT +4/5 IS WORD COUNT.
03800 MOVEI A,5 ;BECAUSE WE DON'T WANT TO LOSE B.
03900 IDIVM A ;SEE? NO RANDOM REMAINDER !!
04000 ADD A,SCP ;ADD BASE ADDRESS.
04100 IBP A ;BAGBITING SYSTEM.
04200 SETZM (A) ;ZERO IT.
04300 MOVE SCP
04400 MOVEM ISCP# ;SAVE FOR ERROR PRINTOUT.
04500 POPJ P,
00100 SUBTTL ALGOL SCANNER -- 9/8/66 D. POOLE
00200
00300 ;CALL IS PUSHJ P,-----. SCANS NEXT ATOMIC ELEMENT OF
00400 ; INPUT STRING, RETURNS ELEMENT IN ACCUM. 'A' AS FOLLOWS:
00500 ; UNDEFINED IDENTIFIER-- RETURNS 0.
00600 ; DECLARED IDENTIFIER--- 'A' CONTAINS RANDOM GOOD BITS FROM
00700 ; THE SYM. TBL. IN LEFT HALF, PTR. TO RGB WORD IN RT. HALF.
00800 ;RESERVED WORD OR SINGLE-CHARACTER OPERATOR--- 'A' CONTAINS
00900 ; THE RANDOM BITS WORD FROM EITHER THE RESERVED WORD TABLE
01000 ; OR THE CHAR. CONVERT TABLE, RESPECTIVELY.
01100
01200
01300 BUCKNO←←1; SEE DFUNC BEFORE CHANGING !!!!
01400
01500 ACCUM: BLOCK 40 ;GOOD ENOUGH FOR NOW...
01600
01700 SCANNS: TLOA FL,NOSTAR ;SUPRESS PRINTING OF *.
01800
01900 SCANR: TLOA FL,400000 ;ENTRY WHEN EXPECTING OPERATOR OR
02000 ; RESERVED WORD.
02100 SCANV: TLZ FL,400000 ;ENTRY WHEN EXPECTING VARIABLE.
02200
02300 SCAN:
02400 SKIPE A,SNCHR# ;IF SNCHR IS NON-ZERO,
02500 JRST SL1 ; IT IS THE NEXT CHAR. TO SCAN.
02600 SL10: ILDB A,SCP ;GET NEXT CHAR.
02700 SKIPN A,CTBL(A) ;SKIP LEADING BLANKS.
02800 JRST SL10
02900
03000 JUMPL A,SL1A ;IF OPERATOR, WE'RE DONE.
03100 TLNE A,SNUMF ;CHECK FOR PART OF A NUMBER.
03200 JRST SNUM1
03300 MOVE T2,[POINT 6,ACCUM,5] ;PREPARE TO SCAN AN
03400 SETZB T,ACCUM ;IDENTIFIER.
03500 MOVEM T,ACCUM+1
03600 MOVEM A,FOONLY
03700 SL2: IDPB A,T2 ;APPEND CHAR. TO IDENTIFIER.
03800 ILDB A,SCP ;NEXT CHAR.
03900 SKIPLE A,CTBL(A) ;CHECK FOR TERMINATOR.
04000 AOJA T,SL2 ;INCREMENT COUNT AND LOOP.
04100 TLNE A,SSPC2F ;DOES TERMINATING CHAR. REQUIRE
04200 JRST SSPCB ;IMMEDIATE ATTENTION ?
04300 MOVEM A,SNCHR ;NO, SAVE IT FOR NEXT TIME.
04400 ADDI T,1
04500 DPB T,[POINT 6,ACCUM,5] ;PUT COUNT IN FIRST CHAR.
04600 HRRZS T2
04700 SUBI T2,ACCUM
04800 HRRZM T2,ACCWC#
00100 MOVE A,ACCUM ;PREPARE TO SEARCH TABLES.
00200 MOVE C,ACCUM+1
00300 TLZE FL,400000 ;DO WE EXPECT AN OPERATOR ?
00400 JRST SRSCH ;YES; SEARCH RES. WD. TBL. FIRST
00500 SMSCH: MOVE T,A ;SEARCH MAIN SYM. TBL.
00600 IDIVI T,BUCKNO ;DO HASH ON IDENT.
00700 MOVMS T1 ;MAKE SURE IT'S POSITIVE.
00800 MOVEM T1,CBNO# ;SAVE BUCKET NO.
00900 HRRZ B,BUCTBL(T1) ;HEAD OF RIGHT BUCKET
01000 ; IN SYM. TBL.
01100 SL5: CAMN A,1(B) ;COMPARE FIRST WORDS.
01200 JRST SL4
01300 SL6: HRRZ B,(B) ;GET NEXT ELEMENT OF
01400 JRST SL5 ; THE LINKED LIST.
01500 SL4: CAIN B,A-1 ;FIRST WORD WAS EQUAL...
01600 JRST SNO ; WE ARE AT END OF BUCKET.
01700 SKIPN T1,T2
01800 JRST SFOUND ;ONLY 1 WORD; WE'RE DONE.
01900 CAME C,3(B) ;COMPARE SECOND WORDS...
02000 JRST SL6 ;NOPE.
02100 SOJE T1,SFOUND ;ANY MORE WORDS ?
02200 MOVE T3,[XWD B,4]; YES. PREPARE TO CHECK THEM.
02300 SL7: MOVE D,ACCUM-2(T3)
02400 CAME D,@T3
02500 JRST SL6 ;NOT EQUAL.
02600 SOJE T1,SFOUND ;MORE STILL ?
02700 AOJA T3,SL7 ;YES; KEEP CHECKING.
02800
02900 SFOUND: MOVEI A,2(B) ;FOUND HIM; CALC. PTR. TO RGB WORD.
03000 HLL A,(A) ;GET RANDOM GOOD BITS.
03100 HRRZ B,A
03200 SEXIT: CAIG T2,1 ;MORE THAN 2 WORDS OF NAME ?
03300 POPJ P, ;NO.
03400 SETZM ACCUM(T2) ;YES; ZERO OUT ALL THE WORDS OF
03500 SOJA T2,SEXIT ; ACCUM THAT WE USED.
03600
03700 SNO: TLCN FL,400000 ;NOT IN MAIN TBL; HAVE WE ALREADY
03800 JRST SRSCH ; SEARCHED RES. WORD TBL ?
03900 SN1: MOVE A,FOONLY ;GARPBAZ !
04000 TLNE A,FOOBIT
04100 JRST FOOSCH
04200 SCH1: SETZB A,B ;YES. RETURN 'UNDEFINED'.
04300 POPJ P,
04400
04500 SL1: SETZM SNCHR ;RETURN FOR A SPECIAL CHAR.
04600 SL1A: TLNN A,SSPCF+SSPC2F ;DOES IT NEED SPECIAL SERVICE ?
04700 POPJ P, ;NO.
04800 PUSHJ P,(A) ;YES. DISPATCH ON IT.
04900 JRST SL10 ;CONTINUE SCANNING.
00100 FOOSCH: LDB B,[POINT 6,ACCUM,17]
00200 TRNE FL,SFOOBT ;ARE WE DEFINING A FUNCTION ?
00300 JRST SCH1 ;YES. NO FOO-SYMBOLS ALLOWED.
00400 CAIG B,31 ;IS IT A DIGIT?
00500 CAIGE B,20
00600 JRST SCH1 ;NO.
00700 SUBI B,20 ; TO VALUE.
00800 LDB C,[POINT 6,ACCUM,23]
00900 JUMPE C,FSCH1
01000 LDB D,[POINT 6,ACCUM,29]
01100 JUMPN D,SCH1
01200 IMULI B,12 ;MUL. TENS DIGIT BY 10.
01300 CAIG C,31
01400 CAIGE C,20
01500 JRST SCH1
01600 ADDI B,-20(C) ;ADD IN ONE'S DIGIT.
01700 FSCH1: DPB B,[POINT 17,A,35] ;PUT NUMBER IN A.
01800 POPJ P, ;RETURN FROM SCAN.
01900
02000
02100 S.VT: ;HERE ON VERTICAL TAB.
02200 S.FF: ;FORM FEED.
02300 S.LF: ;LINE FEED
02400 SENDL: TLZ FL,ERRFLG ;END OF LINE. CLEAR ERROR FLAG.
02500 MOVEI A,1
02600 ADD A,SCP ;GET PTR TO NEXT WORD.
02700 SKIPN T,(A)
02800 JRST S.EOB ;ZERO WORD MEANS END OF BUFFER.
02900 TRNN T,1 ;IS IT A LINE NO. ?
03000 POPJ P, ;NO; CONTINUE SCANNING.
03100 TLZ A,770000 ;YES; ADVANCE PTR. PAST IT.
03200 MOVEM A,SCP
03300 POPJ P,
03400 S.EOB: PUSHJ P,RDBUF ;REFILL BUFFER.
03500 JRST SENDL
03600
03700 SSPCB: HALT
03800
03900 SSPCC: HALT
04000
04100 S.LT: ILDB A,SCP ;'<' SEEN; SKIP TO END OF LINE.
04200 CAIE A,12 ;A LINE FEED ?
04300 JRST S.LT ;NO.
04400 JRST SENDL
00100 SNUM1: MOVEI C,0 ;NUMBER SCANNER.
00200 CAMN A,DOTV ;FIRST THING A DECIMAL PT.?
00300 JRST SNUM6 ;YES
00400 MOVNI T,100 ;NO DEC PT. YET.
00500 SNUM2: IMULI C,12
00600 ADDI C,-20(A) ;CONVERT NEW DIGIT TO VALUE AND ADD IN
00700 AOSA T ;INCREMENT DEC. PLACE COUNT.
00800 SNUM6: MOVEI T,0 ;START COUNTING DEC. PLACES.
00900 ILDB A,SCP ;NEXT CHAR.
01000 SKIPG A,CTBL(A) ;GET MAGIC BITS.
01100 JRST SNUM7 ;IT'S A DELIMITER.
01200 TLNE A,SDFLG ;IS IT A DIGIT ?
01300 JRST SNUM2 ;YES.
01400 CAMN A,DOTV ;A DEC. PT. ?
01500 JRST SNUM6 ;YES.
01600 JRST SNUMX1
01700 SNUM7: TLNE A,SSPC2F ;DOES DELIM. REQUIRE INSTANT SERVICE ?
01800 JRST SSPCC ;YES.
01900 MOVEM A,SNCHR ;SAVE FOR NEXT TIME.
02000 ; JUMPLE T,SNFX ;IF NO DEC. PT. SEEN, IT'S FIXED PT.
02100 SFLTIT: IDIVI C,400000 ;FLOAT IT.
02200 SKIPE C
02300 TLC C,254000
02400 TLC D,233000
02500 FAD C,D
02600 SKIPLE T
02700 FDVR C,[10.0] ;DIVIDE BY 10 ENOUGH TO GET
02800 SOJG T,.-1 ;DEC. PT. IN RIGHT PLACE.
02900 SKIPA T,[XWD FLTFLG,0] ;GET FLOATING PT. FLAG.
03000 SNFX: MOVSI T,FIXFLG
03100 HLLZ A,T ;COPY FLAG TO A.
03200 TRNN FL,SFOOBT
03300 TLZE FL,SNUMF1
03400 POPJ P,
00100 ;; NOW SEARCH NUMBER TABLE FOR THE NUMBER.
00200
00300 TDOA A,NUMBUC ;NUMBUC TO RT. HALF.
00400 SNUM4: HRR A,-1(A) ;GET NEXT LINK.
00500 CAME C,(A) ;IS IT EQUAL ?
00600 JRST .-2 ;NO.
00700 TRNN A,777760 ;ARE WE AT END OF TABLE ?
00800 JRST SNUMNO ;YES.
00900 TDNN T,-1(A) ;NO. DO TYPES MATCH ?
01000 JRST SNUM4 ;NO.
01100 POPJ P, ;YUP. WE'VE FOUND IT.
01200
01300 SNUMNO: TRNE FL,CSBRBT ;ARE WE INSIDE A FUNCTION DEFINITION ?
01400 JRST SNUMX ;YES.
01500 AOS B,JOBFF ;INSERT NEW NUMBER IN TABLE.
01600 HRR A,B
01700 EXCH B,NUMBUC ;UPDATE NUMBUC.
01800 HRRM B,-1(A) ;PUT IN NEW LINK.
01900 HLLM A,-1(A) ;PUT IN TYPE FLAG.
02000 MOVEM C,(A) ;ALSO VALUE.
02100 AOS T,JOBFF ;BUMP POINTER PAST VALUE.
02200 HRLM T,JOBSA
02300 POPJ P,
02400
02500 SNUMX: IOR T,VLOC ;WE WILL PUT NO. IN VARIABLES AREA.
02600 PUSH P,T ;SAVE PTR. TO LOC.
02700 MOVE A,C ;VALUE OF NO. TO A.
02800 MOVEI B,0 ;NO RELOCATION.
02900 PUSHJ P,EMVCDI ;EMIT TO VARIABLES BUFFER.
03000 JRST POPAJ ;SEE EMINST.
00100 ; RESERVED WORD TABLE SEARCHER.
00200
00300
00400 SRSCH: LDB B,[POINT 6,ACCUM,5] ;GET CHAR. COUNT.
00500 CAIL B,3 ;NO 1-CHAR. RES. WDS.
00600 CAILE B,13 ;ALSO NONE OF > 9 CHARS.
00700 JRST SRNO
00800 MOVE B,SRTBL1-2(B) ;GET RIGHT SECTION OF TBL.
00900 CAME A,(B) ;COMPARE FIRST WORD.
01000 SRS1: AOBJN B,.-1
01100 JUMPGE B,SRNO ;ARE WE AT END OF SETCTION ?
01200 CAME C,LRTBL(B) ;NO; COMPARE SECOND WORD.
01300 JRST SRS1
01400 MOVE A,2*LRTBL(B) ;THIS IS IT; GET GOOD BITS.
01500 TLNE A,SSPCF ;DOES IT NEED OUR ATTENTION ?
01600 JRST (A) ;YES.
01700 JRST SEXIT ;NO.
01800
01900 SRNO: TLCN FL,400000 ;NOT A RES. WORD; HAVE WE ALREADY
02000 JRST SMSCH ;SEARCHED MAIN SYM. TBL. ?
02100 JRST SN1 ; YES; RETURN.
02200
02300 .COMME: MOVE A,SNCHR ;A COMMENT; SKIP TO NEXT ';'
02400 SETZM SNCHR
02500 .COMM1: CAMN A,SEMICV
02600 JRST SCAN
02700 TLNE A,SSPCF+SSPC2F ;SPECIAL TREATMENT ?
02800 PUSHJ P,(A) ;YES.
02900 ILDB A,SCP
03000 MOVE A,CTBL(A)
03100 JRST .COMM1
03200
03300
03400 BUCTBL: REPEAT BUCKNO,<EXP TEMPSY> ;TABLE OF HEADS OF THE
03500 ;HASH-CODED BUCKETS IN SYM. TABLE.
03600
03700 NUMBUC: EXP C ;HEAD OF NUMBER TABLE
00100 ;THE CHARACTER CONVERSION TABLE -- GOOD BITS FOR EVERYONE !
00200 ; GET YOURS WHILE THEY LAST !
00300
00400 OPDEF ILG [XWD DF+SSPCF,SILCH]
00500
00600 CTBL: XWD DF+SSPCF,SENDL
00700 REPEAT 10,<ILG>
00800 0 ; HORIZONTAL TAB.
00900 XWD DF+SSPCF,S.LF ;LINE FEED
01000 XWD DF+SSPCF,S.VT ; VERTICAL TAB
01100 XWD DF+SSPCF,S.FF ;FORM FEED
01200 0 ;CARRIAGE RETURN.
01300 REPEAT 14,<ILG>
01400 XWD DF+SSPCF,SENDL ;↑Z.
01500 REPEAT 5,<ILG>
01600 0 ;SPACE
01700 REPEAT 7,<ILG>
01800 LPARV: XWD DF,1
01900 RPARV: XWD DF,2
02000 XWD DF+MULBIT,MULOP ; *
02100 PLSV: XWD DF+ADDBIT,ADDOP ; +
02200 COMMAV: XWD DF,COMMOP ; ,
02300 MINV: XWD DF+ADDBIT,SUBOP ; -
02400 DOTV: XWD SNUMF,"." ; .
02500 XWD DF+MULBIT,DIVOP ; /
02600 CTNUM: REPEAT 12,<XWD SDFLG+SNUMF,20+.-CTNUM> ; THE DIGITS.
02700
02800 COLONV: XWD DF,3 ; :
02900 SEMICV: XWD DF,4 ; ;
03000 XWD DF+SSPCF,S.LT ;<
03100 ;; XWD DF+RELBIT,EOP ; =
03150 XWD DF,ASNOP ;← AND = DO THE SAME THING. 5/74
03200 XWD DF+RELBIT,GOP ; >
03300 REPEAT 2,<ILG>
03400 CTLTR: REPEAT =5,<XWD 0,41+.-CTLTR> ;THE LETTERS.
03500 41+.-CTLTR ;F
03600 REPEAT =9,<41+.-CTLTR>
03700 XWD FOOBIT,41+.-CTLTR+400000 ;P
03800 REPEAT 4,<41+.-CTLTR>
03900 XWD FOOBIT,41+.-CTLTR
04000 REPEAT 5,<41+.-CTLTR>
04100
04200 LFTBRK: XWD DF,5 ; [
04300 ILG
04400 RGTBRK: XWD DF,6
04500 UARV: XWD DF,EXPOP ; ↑
04600 LARV: XWD DF,ASNOP ;← LEFT ARROW??
04700 REPEAT 35,<ILG>
04800 ALTV: XWD DF,. ;ALT MODE.
04900 REPEAT 2,<ILG>
05000 ; END OF CONVERT TABLE.
00100 DEFINE PUT1 (N,Y)
00200 < FOR X IN (Y)
00300 <Q←<SIXBIT /X/>
00400 N*10000000000+(7777777777&(Q/100))
00500 >>
00600
00700 DEFINE PUT2 (Y)
00800 <FOR X IN (Y)
00900 <SIXBIT /X/
01000 >>
01100
01200 RTBL: ;THE RESERVED WORD TABLE.
01300 RT3C: PUT1 (3,END) ;THE 3-LETTER SECTION.
01400 RT4C: PUT1(4,<PLAY>)
01500 RT5C: PUT1(5,<ARRAY>)
01600 RT6C: PUT1 (6,FINIS) ;THE 6-LETTER SECTION.
01700 RT7C: PUT1 (7,<COMME,COMPI>)
01800 RT8C: PUT1 (10,<VARIA,FUNCT,EXTER>) ;VARIABLE
01900 RT10C: PUT1 (12,INSTR) ;
02000
02100 LRTBL←←.-RTBL
02200
02300 RTBL2: 0 ;END
02400 0 ;PLAY.
02500 0
02600 PUT2 (H)
02700 PUT2 (<NT,LE>) ;COMMENT
02800 PUT2 (<BLE,ION,NAL>)
02900 PUT2 (UMENT) ;INSTRUMENT
03000
03100 RF←←DF+RFLG
03200
03300 RTBL3:
03400 ENDV: XWD RF,.
03500 PLAYV: XWD RF,.
03600 ARRV: XWD RF+DECLBIT,DARR
03700 FINV: XWD RF,.
03800 COMV: XWD SSPCF,.COMME
03900 COMPV: XWD RF,.
04000 VARV: XWD RF+DECLBIT,DVRBL
04100 FUNV: XWD RF+DECLBIT,DFUNC ;FUNCTION
04200 EXTV: XWD RF+DECLBIT,EXTD
04300 INSV: XWD RF+DECLBIT,CINS
04400
04500 SRTBL1: 0 ;2
04600 XWD -1,RT3C
04700 XWD -1,RT4C
04800 XWD -1,RT5C
04900 XWD -1,RT6C
05000 XWD -2,RT7C
05100 XWD -3,RT8C
05200 0
05300 XWD -1,RT10C
05400 0
05500 SRSFOO: JUMP 2*LRTBL(B)
00100 ;; MORE BITS AND PARAMETERS.
00200 RELBIT←←0
00300
00400 ;SIZES OF VARIOUS STACKS AND TABLES:
00500 LOBUFS←←200
00600 LUOTBL←←62
00700 LPLIST←←100
00800 LOSTK←←40
00900 LPA←←62
01000 LRQ←←=75 ;LENGTH OF RUN QUEUE.
01100
01200 ;SPECIAL AC DEFINITIONS :
01300 RA←16 ;AC FOR JSA LINKAGE AT RUNTIME.
01400
01500
01600 DEFINE MAKOP1 (X)
01700 <FOR @$ A IN (X)
01800 <A$OP: HALT
01900 >>
02000
02100 MAKOP1 <PW,COMM,L,E,G,EXP,ENDS,WHLS>
02200
02300 ;; TEMPORARY AND DEBUGGING ROUTINES:
02400
02500 GO: MOVE P,[IOWD LPLIST,PLIST]
02600 AOSE ONCEFG ;IS THIS FIRST TIME THROUGH ?
02700 JRST GOA ;NO. LEAVE JOBFF AT CURRENT PLACE.
02800 HRLZ 116 ;YES. GET BOTTOM OF SYM. TAB. FROM JOBSYM.
02900 SUB 116 ;ADD LENGTH OF SYM. TAB.
03000 HRLM JOBFF
03100 GOA: HRR JOBFF
03200 HRLM JOBSA
03300 MOVEI FL,0
03400 PUSHJ P,SETUP
03500 GOB: MOVE P,[IOWD LPLIST,PLIST]
03600 MOVE [JSR ERR1] ;SET UP FOR ERROR UUO.
03700 MOVEM 41
03800 MOVE JOBREL
03900 MOVEM JOBSYM
04000 JRST SCHOWN
04100
04200 ONCEFG: -1
04300
04400 DEFINE ERROR (M)
04500 <XWD 1000,[ASCIZ /M/] >
04600
04700
04800 UDIERR: ERROR (UNDEFINED IDENTIFIER)
04900
05000 SILCH: ERROR (ILLEGAL CHARACTER)
05100 SNUMX1: ERROR(ILLEGAL CHAR. IN NUMBER)
05200 FNDWV: HALT
05300 ;USEFUL F4 FUNCTIONS TO HAVE AROUND....
05400 EXTERNAL SIN,COS,EXP,ALOG,SQRT
05500
00100 TEMPSY: EXP TMPS1Z
00200 PUT1 5,OSCIL
00300 XWD UGBIT,.+2
00400 0
00500 JSP RA,@OSCIL ;POINTER DID NOT RESET WITH '1,5,0,1' IN NEXT!!!!
00600 BYTE (6)4,2,2,1,4,0,1;***** JULY 3,71 THIS ENDED '1,5,0,1' ****
00700 TMPS1Z: TMPS1
00800 PUT1 6,ZOSCI
00900 XWD UGBIT,.+3
01000 PUT2 (L)
01100 0
01200 JSP RA,@ZOSCIL
01300 BYTE (6)4,2,2,1,5,0,1 ;WAS ....,4,0,1 - NOW LIKE COSCIL
01400 TMPS1: EXP TIMESC+1
01500 PUT1 6,TIMES
01600 XWD VRBLBT,TIMESC
01700 PUT2 C
01800 TIMESC: 1.0
01900 EXP SRATE+1
02000 PUT1 5,SRATE
02100 XWD VRBLBT,SRATE
02200 SRATE: 10000.0
02300 EXP NCHNS+1
02400 PUT1 5,NCHNS
02500 XWD VRBLBT,NCHNS
02600 NCHNS: 1
02700 EXP LSBUF+1
02800 PUT1 5,LSBUF
02900 XWD VRBLBT,LSBUF
03000 LSBUF: 1000
03100 EXP TMPS2
03200 PUT1 3,OUT
03300 XWD UGBIT,.+2
03400 0
03500 JSA RA,@OUT
03600 BYTE (6)1,2,0,0
03700 TMPS2: EXP TMPS3
03800 PUT1 4,OUT2
03900 XWD UGBIT,.+2
04000 0
04100 JSA RA,@OUT2
04200 BYTE (6)3,2,2,2,0,0
04300 TMPS3: TMPS11
04400 PUT1 5,SPEED
04500 XWD VRBLBT,SPEED
04600 SPEED: 1
04700 TMPS11: TMPS12
04800 PUT1 6,VFMUL
04900 XWD UGBIT,.+3
05000 PUT2 T
05100 0
05200 JSP RA,@VFMULT
05300 BYTE (6)3,2,2,1,0,T
05400 TMPS12: TMNOSA
05500 PUT1 6,NOSCI
05600 XWD UGBIT,.+3
05700 PUT2 L
05800 0
05900 JSP RA,@NOSCIL
06000 BYTE (6)4,2,2,1,4,0,1
06100
06200 TMNOSA: TMPS13
06300 PUT1 5,NOSCA
06400 XWD UGBIT,.+2
06500 JSA RA,INOSCA
06600 JSP RA,@NOSCA
06700 BYTE (6)5,2,2,2,1,5,0,T
06800
06900 ;TMPS13: TMPS14
07000 ; PUT1 10,DISKF
07100 ; XWD VRBLBT,DISKFL
07200 ; PUT2 LAG
07300 ;DISKFL: 0
07400
07500 TMPS13: TMPS24
07600 PUT1 5,INTRP
07700 XWD UGBIT,.+2
07800 JSA RA,IINTRP
07900 JSP RA,@INTRP
08000 BYTE (6)5,2,2,5,1,4,0,T
08100 TMPS24: TMPS14
08200 PUT1 4,READ
08300 XWD UGBIT,.+2
08400 JSP RA,READI
08500 JSP RA,@READ
08600 BYTE (6)6,2,2,1,2,5,5,0,T
08700 TMPS14: TMPS15
08800 PUT1 4,REVX
08900 XWD UGBIT,.+2
09000 JSP RA,REVXI
09100 JSP RA,@REVX
09200 BYTE (6)20,2,2,2,2,2,2,2,2,2,4,4,4,4,4,1,4,0,T
09300
09400 TMPS15: .+3
09500 PUT1 4,OUTA
09600 XWD VRBLBT,OUTA
09700 .+3
09800 PUT1 4,OUTB
09900 XWD VRBLBT,OUTB
10000 .+3
10100 PUT1 4,OUTC
10200 XWD VRBLBT,OUTC
10300 .+4 ;DOPLAY←1=WILL PLAY WHEN WRITING SMPLS ON DSK
10400 PUT1 6,DOPLA
10500 XWD VRBLBT,DOPLAY#
10600 PUT2 Y
10700 .+3
10800 PUT1 4,OUTD
10900 XWD VRBLBT,OUTD
11000 .+4 ;RCDFLG←1 PUTS SAMPLES ON DSK UNDER 'MUSAA','MUSAB',ETC.
11100 PUT1 6,RCDFL
11200 XWD VRBLBT,RCDFLG#
11300 PUT2 G
11400 ; .+4
11500 ; PUT1 6,DSKFL
11600 ; XWD VRBLBT,DSKFLG#
11700 ; PUT2 G
11800 .+4
11900 PUT1 6,BIGBI
12000 XWD VRBLBT,BIGBIT#
12100 PUT2 T
12200 .+6
12300 PUT1 5,VALUE
12400 XWD UGBIT,.+2
12500 0
12600 JSP RA,@VALUE
12700 BYTE (6)1,2,0,T
12800 .+5
12900 PUT1 4,RAND
13000 XWD FUNBIT,.+1
13100 PUSHJ P,RAND
13200 BYTE (6)0,T
13300 FRSTB+1
13400 PUT1 =9,FIRST
13500 XWD VRBLBT,FRSTB
13600 PUT2 BAND
13700 FRSTB: 0
13800 .+5
13900 PUT1 5,PRINT
14000 XWD FUNBIT,.+1
14100 JSA RA,FOOPRT
14200 BYTE (6)1,2,0,0
14300 .+3
14400 PUT1 3,RDA
14500 XWD RVBT∨VRBLBT,RDA
14600 .+3
14700 PUT1 3,RDB
14800 XWD RVBT∨VRBLBT,RDB
14900 .+3
15000 PUT1 3,RDC
15100 XWD RVBT∨VRBLBT,RDC
15200 .+3
15300 PUT1 3,RDD
15400 XWD RVBT∨VRBLBT,RDD
00100 TMPSA: EXP TMPS4 ;LINEN.
00200 PUT1 5,LINEN
00300 XWD UGBIT,.+2
00400 JSA RA,LINEN1
00500 JSP RA,@LINEN
00600 ; BYTE (6)13,4,4,4,2,2,2,2,1,4,4,4,0,1
00700 BYTE (6)13,4,4,4,2,2,2,2,1,2,4,4,0,1
00800 ;NOW YOU MUST RESET PTR IN LINEN
00900 TMPS4: EXP TMPS5
01000 PUT1 5,EXPEN
01100 XWD UGBIT,.+2
01200 0
01300 JSP RA,@EXPEN
01400 BYTE (6)4,2,2,1,4,0,1
01500
01600 TMPS5: EXP TMPS6
01700 PUT1 (4,REV1) ;REV1
01800 XWD UGBIT,.+2
01900 JSP RA,REVI
02000 JSP RA,@REV1
02100 BYTE (6)6,2,2,2,1,5,4,0,1
02200 TMPS6: EXP TMPS7
02300 PUT1 4,REV2
02400 XWD UGBIT,.+2
02500 JSP RA,REVI
02600 JSP RA,@REV2
02700 BYTE (6)6,2,2,2,1,5,4,0,1
02800
02900 TMPS7: EXP TMPS8
03000 PUT1 (7,REVIN) ;REVINIT.
03100 XWD VRBLBT,REVINI
03200 PUT2 IT
03300 REVINI: 0
03400
03500 TMPS8: EXP TMPS9
03600 PUT1 (5,RANDH)
03700 XWD UGBIT,.+2
03800 JSP RA,IRANDH
03900 JSP RA,@RANDH
04000 BYTE (6)4,2,2,4,4,0,1
04100 TMPS9: EXP TMPS10
04200 PUT1 (5,RANDI)
04300 XWD UGBIT,.+2
04400 JSP RA,IRANDI
04500 JSP RA,@RANDI
04600 BYTE (6)5,2,2,4,4,4,0,1
04700 TMPS10: EXP A-1
04800 PUT1 6,COSCI
04900 XWD UGBIT,.+3
05000 PUT2 L
05100 0
05200 JSP RA,@NOSCIL
05300 BYTE (6)4,2,2,1,5,0,1
00100 ;; HERE ARE SOME WONDERFUL UNIT GENERATORS.
00200
00300 OSCIL: MOVE INSXR,3(RA)
00400 FIX INSXR,233000
00500 TRZE INSXR,777000
00600 JSP T1,OSCIL1
00700 MOVE T,@2(RA)
00800 FMPR T,@(RA)
00900 SKIPGE T1,@1(RA) ;OSCIL DOESN'T WANT NEG. INC.
01000 ERROR (NEGATIVE INC. TO OSCIL)
01100 FADM T1,3(RA)
01200 JRST 4(RA)
01300 NOSCA: ADDI RA,1
01400 NOSCIL: MOVE INSXR,3(RA)
01500 FAD INSXR,[0.5]
01600 FIX INSXR,233000
01700 TRZE INSXR,777000
01800 JSP T1,OSCIL1
01900 MOVE T,@2(RA)
02000 FMPR T,@(RA)
02100 MOVE T1,@1(RA)
02200 FADM T1,3(RA)
02300 JRST 4(RA)
02400 OSCIL1: MOVSI (-512.0) ;WRAP AROUND THE POINTER.
02500 JUMPGE INSXR,.+2
02600 MOVNS 0 ;IF NEG. INC., WRAP AROUND OTHER WAY.
02700 FADM 3(RA)
02800 JRST (T1)
02900
03000 OUT: 0
03100 MOVE @(RA) ;PICK UP INPUT.
03200 FADM OUTA ;ACCUMULATE INTO OUTPUT ARRAY.
03300 POPJ P, ;RETURN FROM INSTRUMENT.
03400
03500 OUT2: 0
03600 MOVE @(RA)
03700 MOVE 1,0
03800 FMP @1(RA)
03900 FADM OUTA ;
04000 FMP 1,@2(RA)
04100 FADM 1,OUTB
04200 POPJ P,
04300
04400 EXPEN: MOVE INSXR,@1(RA) ;GET INCREMENT.
04500 FADB INSXR,3(RA) ;INCREMENT POINTER.
04600 FIX INSXR,233000
04700 CAIL INSXR,777 ;IF GREATER THAN 512, STICK
04800 MOVEI INSXR,777 ;AT LAST ELEMENT OF ARRAY.
04900 MOVE T,@2(RA) ;GET ARRAY ELEMENT.
05000 FMPR T,@(RA) ;MULTIPLY BY AMPLITUDE.
05100 JRST 4(RA) ;RETURN.
05200 VFM2: FSBR INSXR,[512.0] ;YOU MUST NOW SET PTR FOR VFMULT!
05300 MOVEM INSXR,@VFMULT
05400
05500 VFMULT: MOVE INSXR,@1(RA) ;GET POINTER INPUT.
05600 CAML INSXR,[512.0]
05700 JRST VFM2
05800 FIX INSXR,233000
05900 MOVE T,@2(RA) ;GET INDICATED ELEMENT OF ARRAY.
06000 FMPR T,@(RA) ;MULT. BY AMPLITUDE.
06100 JRST 3(RA)
06200
06300 INOSCA: 0
06400 MOVE T,(RA)
06500 MOVE T1,@-6(T)
06600 MOVEM T1,-2(T)
06700 JRA RA,1(RA)
06800 INTRP: ADDI RA,1
06900 MOVE INSXR,3(RA)
07000 FIX INSXR,233000
07100 TRZE INSXR,777000
07200 JSP T1,OSCIL1
07300 MOVE T,@2(RA)
07400 FMPR T,@(RA)
07500 FADR T,@-1(RA)
07600 MOVE T1,1(RA)
07700 FADM T1,3(RA)
07800 JRST 4(RA)
07900
08000 IINTRP: 0
08100 MOVE T,(RA)
08200 MOVE T1,@-5(T)
08300 FSBR T1,@-6(T)
08400 MOVEM T1,@-5(T)
08500 MOVSI T1,(512.0)
08600 FDVR T1,SRATE
08700 FDVR T1,PBASE+2
08800 MOVEM T1,-4(T)
08900 JRA RA,1(RA)
09000
09100 READ: AOS INSXR,4(RA)
09200 CAML INSXR,5(RA)
09300 JRST READ1
09400 MOVEI T,0
09500 LCS2: MOVE @2(RA)
09600 MOVEM RDA(T)
09700 ADDI T,1
09800 CAML T,3(RA)
09900 JRST 7(RA)
10000 AOS INSXR,4(RA)
10100 JRST LCS2
10200
10300 READ1: MOVE 2(RA)
10400 MOVEM LCS+3
10500 SUBI 1
10600 HRRZM LCS+4
10700 LCS: JSA 16,READIN
10800 0
10900 0
11000 0
11100 0
11200 [-1]
11300 SETZB INSXR,4(RA)
11400 JRST READ+3
11500
11600 READI: MOVE T,(RA)
11700 MOVE T2,@-4(T)
11800 FIX T2,233000
11900 MOVEM T2,-4(T)
12000 MOVE T2,-7(T)
12100 MOVEM T2,LCS1+1
12200 MOVE T2,-6(T)
12300 MOVEM T2,LCS1+2
12400 MOVE T1,-5(T)
12500 MOVE T2, -1(T1)
12600 MOVEM T2,-2(T)
12700 SETOM -3(T)
12800 MOVEM T1,LCS1+3
12900 LCS1: JSA RA,READIN
13000 0
13100 0
13200 0
13300 T2
13400 [0]
13500 JRST 1(RA)
13600
13700 ZOSCIL: MOVE INSXR,3(RA) ;ZOSCIL WORKS LIKE COSCIL BUT NOT NOSCIL!
13800 FIX INSXR,233000
13900 TRZE INSXR,777000
14000 JSP T1,OSCIL1
14100 MOVE T,@2(RA)
14200 move insxr
14300 move t1,t
14400 cain insxr,777
14500 tdza insxr,insxr
14600 addi insxr,1
14700 fsbr t1,@2(ra)
14800 fsc 233
14900 fsb 3(ra)
15000 fmpr t1,0
15100 fadr t,t1
15200 FMPR T,@(RA)
15300 ;; SKIPGE T1,@1(RA) ;OSCIL DOESN'T WANT NEG. INC.
15400 MOVE T1,@1(RA) ;ZOSCIL WILL NOW TAKE NEG. INC.
15500 ;; ERROR (NEGATIVE INC. TO ZOSCIL)
15600 FADM T1,3(RA)
15700 JRST 4(RA)
15800
15900
16000 ZNOSC: MOVE INSXR,3(RA)
16100 FIX INSXR,233000
16200 TRZE INSXR,777000
16300 JSP T1,OSCIL1
16400 MOVE T,@2(RA)
16500 MOVE INSXR
16600 MOVE T1,T
16700 SKIPGE 4(RA)
16800 JRST .+5
16900 CAIN INSXR,777
17000 TDZA INSXR,INSXR
17100 ADDI INSXR,1
17200 JRST .+4
17300 JUMPN INSXR,.+2
17400 TDOE INSXR,777
17500 SUBI INSXR,1
17600 FSBR T1,@2(RA)
17700 FSC 233
17800 FSB 3(RA)
17900 FMPR T1,0
18000 FADR T,T1
18100 FMPR T,@(RA)
18200 MOVE T1,@1(RA)
18300 MOVEM T1,4(RA)
18400 FADM T1,3(RA)
18500 JRST 5(RA)
00100 ;; REVERBERATION UNIT GENERATORS.
00200
00300 ; REV1 IS THE SIMPLE FED-BACK DELAY LOOP, OR 'COMB FILTER'.
00400
00500 REV1: AOS INSXR,4(RA) ;INCREMENT OUTPUT PTR.
00600 CAML INSXR,5(RA) ;IS IT TIME TO WRAP AROUND ?
00700 SETZB INSXR,4(RA) ;YES.
00800 MOVE 1,@3(RA) ;GET OUTPUT OF DELAY LINE.
00900 MOVE 2,1 ;LEAVE IN 1 AS FINAL OUTPUT.
01000 FMPR 2,@2(RA) ;MULTIPLY BY FEEDBACK GAIN.
01100 REVA: MOVE @1(RA) ;GET DELAY TIME, T.
01200 FIX 233000
01300 ADD INSXR,0 ;MOVE PTR. AROUND TO INPUT END.
01400 CAML INSXR,5(RA) ;PROBABLY HAVE TO WRAP AROUND..
01500 SUB INSXR,5(RA) ;YUP. SUBTRACT LENGTH OF DELAY ARRAY.
01600 FADR 2,@(RA) ;ADD IN THE INPUT SAMPLE.
01700 MOVEM 2,@3(RA) ;PLACE IN INPUT OF DELAY LINE.
01800 JRST 6(RA) ;RETURN.
01900
02000 ;REV2 IS THE ALL-PASS REVERBERATOR.
02100
02200 REV2: AOS INSXR,4(RA) ;CALC. PTR. AS IN REV1.
02300 CAML INSXR,5(RA)
02400 SETZB INSXR,4(RA)
02500 MOVN 1,@3(RA) ;GET NEGATIVE OF OUTPUT OF DELAY.
02600 MOVN 0,@2(RA) ;ALSO NEGATIVE OF GAIN, G.
02700 FMPR 1,0 ;FORM GAIN*OUTPUT
02800 MOVE 2,1 ;(NOTE THIS IS POSITIVE).
02900 FMPR 1,0 ;FORM -G↑2 * OUTPUT.
03000 FADR 1,@3(RA) ;(1-G↑2) * OUTPUT.
03100 FMPR 0,@(RA) ;FORM -G * INPUT.
03200 FADR 1,0 ;FINAL OUTPUT IS -G*IN +(1-G↑2)*OUT.
03300 JRST REVA ;FROM HERE ON, SAME AS REV1.
03400
03500 ; THIS IS THE I-TIME CODE FOR REV1 AND REV2.
03600
03700 REVI: HRRZ T1,(RA) ;GET PTR. TO END OF REV PARAMS.
03800 MOVNI INSXR,1 ;INSXR←-1
03900 HRRZ @-4(T1) ;GET -1ST ELEMENT OF ARRAY (THE LENGTH)
04000 MOVEM -2(T1) ;PLACE IN THE SECOND DUMMY PARAM.
04100 SKIPN REVINI ;SHOULD WE INIT. THE DELAY ARRAY ?
04200 JRST 1(RA) ;NO.
04300 SETZM -3(T1) ;YES. FIRST CLEAR THE POINTER LOC.
04400 HRRZ T,-4(T1) ;GET PTR. TO ARRAY.
04500 REVI2: ADDI -1(T) ; 0 NOW POINTS TO TOP OF ARRAY.
04600 HRL T,T
04700 SETZM (T) ;CLEAR FIRST ELEMENT OF ARRAY.
04800 ADDI T,1 ;FORM BLT POINTER.
04900 BLT T,@0 ;CLEAR REST OF ARRAY.
05000 JRST 1(RA)
05100
00100 ;; MORE GENERATORS.
00200
00300 LINEN: MOVE INSXR,11(RA) ;GET INCREMENT.
00400 ; FADB INSXR,10(RA) ;ADD TO POINTER.
00500 FADB INSXR,@10(RA) ;NOW YOU MUST RESET PTR
00600 LINEN4: CAML INSXR,12(RA) ;ARE WE PAST END OF SECTION ?
00700 JRST LINEN2 ;YES.
00800 FIX INSXR,233000
00900 MOVE T,@3(RA) ;AMPLITUDE.
01000 FMPR T,@7(RA) ;MULT. BY ARRAY ELEMENT.
01100 JRST 13(RA) ;RETURN.
01200
01300 LINEN2: MOVE T,12(RA) ;PICK UP CURRENT LIMIT.
01400 FIX T,242000
01500 CAIL T,3 ;END OF ARRAY ?
01600 JRST LINEN3 ;YES.
01700 HRLI T,RA ;PREPARE FOR INDEXING...
01800 MOVE @T ;PICK UP NEXT INCREMENT.
01900 MOVEM 11(RA) ;PUT AWAY.
02000 MOVSI (128.0)
02100 FADM 12(RA) ;INCREMENT LIMIT TO NEXT VALUE.
02200 JRST LINEN4
02300 LINEN3: MOVEI 14(RA) ;FAKE UP A PARAMETER FOR LINEN1.
02400 MOVEM .+2
02500 JSA RA,LINEN1 ;RE-INITIALIZE THE GENERATOR.
02600 0 ;
02700 ; SETZM 10(RA) ;RESET PTR.
02800 SETZM @10(RA) ;NOW YOU MUST RESET PTR
02900 SETZM 11(RA) ;AND INCREMENT.
03000 SETZM 12(RA) ;...AND LIMIT.
03100 JRST LINEN
03200
03300 LINEN1: 0 ;THE INITIALIZING CODE FOR LINEN.
03400 MOVE T2,(RA) ;GET POINTER TO END OF PARAMETERS.
03500 MOVE T1,TIMESC ;CALC. 128*(BEATS/SAMPLE)
03600 FDVR T1,SRATE
03700 FSC T1,7
03800 MOVE T,@-10(T2) ;GET RISE TIME IN BEATS.
03900 FDVRM T1,T ;INCREMENT←T1/TIME (=128/(TIME IN SAMPS))
04000 MOVEM T,-14(T2) ;PLACE IN PARAMETER 0.
04100 MOVE T,@-6(T2) ;DURATION OF NOTE IN BEATS...
04200 FSBR T,@-7(T2) ;...MINUS FALL TIME..
04300 FSBR T,@-10(T2) ;...MINUS RISE TIME.
04400 FDVRM T1,T ;CHANGE TO INCREMENT.
04500 MOVEM T,-13(T2) ;PLACE IN PARAMETER 1.
04600 FDVR T1,@-7(T2) ;INCREMENT FOR FALL TIME.
04700 MOVEM T1,-12(T2) ;PLACE IN PARAMETER 2.
04800 JRA RA,1(RA)
04900
05000 VALUE: MOVE T,@(RA) ;DUMMY UNIT GENERATOR... OUTPUT IS
05100 JRST 1(RA) ;SAME AS ITS PARAMETER.
00100 ;; RANDOM NUMBER GENERATORS.
00200
00300 RANDH: MOVE @1(RA) ;GET INCREMENT.
00400 FADB 2(RA) ;INCREMENT THE 'POINTER'.
00500 CAML [512.0] ;OVER 512 ?
00600 JRST RNDH2 ;YES. GO GET NEW RANDOM NUMBER.
00700 MOVE T,@(RA) ;NO. GET INPUT ...
00800 FMPR T,3(RA) ;... AND MULT. BY CURRENT RANDOM NO.
00900 JRST 4(RA) ;RETURN.
01000 RNDH2: MOVSI (-512.0) ;CAUSE 'POINTER' TO 'WRAP AROUND'.
01100 FADM 2(RA)
01200 PUSHJ P,RAND ;GET NEW RANDOM NO.
01300 MOVEM T,3(RA) ;MAKE IT THE CURRENT NO.
01400 FMPR T,@(RA) ;MULT. BY INPUT.
01500 JRST 4(RA) ;RETURN.
01600
01700 IRANDI: ;I-TIME CODE FOR RANDI AND RANDH.
01800 IRANDH: PUSHJ P,RAND ;INIT. RANDH.
01900 MOVE T2,(RA) ;GET PTR. TO LAST PARAM..
02000 MOVEM T,-2(T2) ;PUT INITIAL RAND. NO. IN.
02100 JRST 1(RA)
02200
02300 RANDI: MOVE T,2(RA) ;GET CURRENT DELTA..
02400 FADRB T,4(RA) ;ADD TO LAST OUTPUT VALUE...
02500 SOSG 3(RA) ;DECREMENT STEP COUNTER ...
02600 JRST RNDI2 ;IT'S 0, SO GET NEW RANDOM NO.
02700 FMPR T,@(RA) ;NO. MULT BY INPUT.
02800 JRST 5(RA) ;RETURN.
02900 RNDI2: PUSHJ P,RAND ;GET NEXT RANDOM NO.
03000 FSBR T,4(RA) ;FORM DELTA (=NEW - OLD)
03100 MOVSI T1,(512.0)
03200 FDVR T1,@1(RA) ;NO. OF STEPS = 512/(FREQ. INPUT)
03300 FDVR T,T1 ;CHANGE PER STEP =DELTA/NO. OF STEPS
03400 MOVEM T,2(RA) ;STORE CHANGE PER STEP.
03500 FIX T1,233000
03600 MOVEM T1,3(RA) ;PUT IT AWAY.
03700 JRST RANDI ;NOW GO GENERATE FIRST STEP.
03800
03900 RAND: MOVE T,RNDNO1 ;GENERATE A RANDOM NO.
04000 ADD T,RNDNO2
04100 EXCH T,RNDNO2
04200 MOVEM T,RNDNO1
04300 ASH T,-10 ;SMEAR SIGN INTO EXPONENT FIELD..
04400 FSC T,200 ;... AND FLOAT IT IN RANGE -1 TO 1.
04500 POPJ P,
04600 RNDNO1: 756132257563
04700 RNDNO2: 756132257565
00100 PLIST: BLOCK LPLIST
00200
00300 OSTK: BLOCK LOSTK
00400
00500 RQ1: BLOCK LRQ ;THE RUN QUEUE, CLOUMN ONE.
00600 RQ2: BLOCK LRQ ;COLUMN TWO.
00700
00800 PATCH: BLOCK 100
00900
01000 IARR1: ;; HERE BEGINS AN AREA WHICH IS ZEROED DURING
01100 ; INITIALIZATION OF EACH COMPILATION.
01200
01300 UOTBL: BLOCK LUOTBL
01400
01500 ACS:
01600 RACS: BLOCK 20
01700 IACS: BLOCK 20
01800
01900 UOPTR: -1
02000
02100 IARR2:
02200
02300 PBASE: BLOCK LPA
02400
02500 OUTA: 0 ;CHANNEL A OUTPUT SAMPLE ACCUMULATED HERE.
02600 OUTB: 0 ;CHANNEL B.
02700 OUTC: 0 ;CHANNEL C.
02800 OUTD: 0 ;CHANNEL D.
02900
03000 RDA: 0
03100 RDB: 0
03200 RDC: 0
03300 RDD: 0
03400
03500 IARR3:
03600
03700
03800 VLOC: 0
03900 ILOC: 0
04000 RLOC: 0
04100
04200 DSKMAX: =76*2000*17
00100 ;; THIS IS THE MULTIPLE-FEEDBACK REVERBERATOR.
00200 ;; ITS DELAY TIMES MUST NOT BE R-TIME VARIABLES.
00300
00400 REVX: SOSGE INSXR,15(RA) ; ADVANCE PTR. TO 4TH TAP.
00500 JSP T1,REVX1 ;TIME TO WRAP AROUND....
00600 MOVE T,@16(RA) ;GET DELAY ARRAY OUTPUT FROM 4TH TAP..
00700 FMP T,@10(RA) ;MULT. BY GAIN NO. 4
00800 SOSGE INSXR,14(RA) ;NOW PTR. TO 3RD TAP.
00900 JSP T1,REVX1
01000 MOVE @16(RA) ;... 3RD TAP DELAY OUTPUT...
01100 FMP @6(RA) ;...3RD GAIN...
01200 FAD T,0 ;ACCUMULATE SUM IN T.
01300 SOSGE INSXR,13(RA) ;2ND TAP PTR.
01400 JSP T1,REVX1 ;THIS COULD GET BORING.
01500 MOVE @16(RA)
01600 FMP @4(RA) ;GAIN 2.
01700 FAD T,0
01800 SOSGE INSXR,12(RA) ;ONE MORE CHORUS.
01900 JSP T1,REVX1
02000 MOVE @16(RA)
02100 FMP @2(RA) ;GAIN 1.
02200 FADB T,0 ;T NOW HAS FINAL OUTPUT(=SUM OF
02300 ; TAPS * GAINS).
02400 FAD @(RA) ;ADD OUTPUT TO INPUT ..
02500 SOSGE INSXR,11(RA) ;.. GET PTR. TO INPUT OF DELAY..
02600 JSP T1,REVX1
02700 MOVEM @16(RA) ;AND PUT IT THERE.
02800 JRST 20(RA) ;WOULD YOU BELIEVE 20 PARAMETERS ??!
02900
03000 REVX1: ADD INSXR,17(RA) ;A PTR. HAS UNDERFLOWED; ADD
03100 MOVEM INSXR,@-2(T1) ; LENGTH OF ARRAY TO IT TO WRAP
03200 JRST (T1) ;IT AROUND (AND STORE UPDATED VERSION).
00100
00200 REVXI: MOVE T1,(RA) ;INITIALIZING FOR REVX.. GET PTR. TO PARAMMS.
00300 MOVNI INSXR,1
00400 MOVE @-3(T1) ;GET -1ST ELEMENT OF ARRAY (= ITS LENGTH).
00500 MOVEM -2(T1) ;STORE IN LAST DUMMY PARAM.
00600 SKIPE REVINI ;IF WE ARE INITIALIZING REVERBERATORS,
00700 SETZM -10(T1) ;RESET INPUT PTR. OF DELAY TO BOTTOM OF ARRAY.
00800 MOVSI T,-4 ;NOW WE SET UP THE FOUR DELAY OUTPUT TAP
00900 HRRI T,-7(T1) ;PTRS. THE RIGHT DISTANCE BEHIND THE INPUT PTR.
01000 MOVEI T2,-20(T1) ;
01100 REVXI2: MOVE @(T2) ;PICK UP DELAY TIME (IN SAMPLES).
01200 FIX 233000
01300 ADD -10(T1) ;ADD TO INPUT PTR. POSITION.
01400 CAML -2(T1) ;WRAP AROUND ?
01500 SUB -2(T1) ;YES. SUB. LENGTH OF ARRAY.
01600 MOVEM (T) ;PLACE PTR. IN RIGHT DUMMY PARAM.
01700 ADDI T2,2 ;INC. T2 TO POINT AT NEXT DELAY TIME PARAM.
01800 AOBJN T,REVXI2 ;LOOP TO GET ALL 4 DELAY TAPS.
01900 SKIPN REVINIT ;ARE WE INITIALIZING REVERBERATORS ?
02000 JRST 1(RA) ;NO. RETURN.
02100 MOVE -2(T1) ;YES GET LENGTH OF ARRAY.
02200 HRRZ T,-3(T1) ;GET BASE OF ARRAY.
02300 JRST REVI2 ;GO ZERO ARRAY (SEE REV1 AND REV2 PAGE).
00100 ; ***** COMPX BEGINS HERE **** ROUTINES TO EMIT CODE AND STUFF TO OUTPUT BUFFERS.
00200 EMDV: SETZB A,B ;EMIT A DUMMY VARIABLE (TO RESERVE
00300 ; SPACE IN THE VARIABLES AREA).
00400 EMVCDI: AOS VLOC
00500 EMVCD: MOVEI T1,2 ;EMIT TO VARIABLE BUFFER.
00600 JRST ECD
00700 EMIABS: TDZA B,B ;EMIT TO I-TIME BUF. , NO RELOC.
00800 EMCDI: AOSA RLOC ;SKIP INSTRUCTIONS WIN BIG.
00900 EMICDI: AOSA ILOC ; SEE THE HAPPY INTERLEAVED CODE !
01000 EMCD: TDZA T1,T1 ;EMIT TO RUNTIME BUFFER.
01100 EMICD: MOVEI T1,1 ;EMIT TO INITIALIZE TIME BUFFER.
01200 ECD:
01300 IDPB A,EMPTR(T1) ;EMIT THE WORD.
01400 IDPB B,RELPTR(T1) ;ALSO ITS RELOCATION BITS.
01500 AOSGE BUFCNT(T1) ;IS BUFFER FULL ?
01600 POPJ P, ;NO. RETURN.
01700
01800 GBUF: ; BUFFER IS FULL; GET A NEW ONE.
01900 MOVNI T,LOBUFS ;LENGTH OF A BUFFER.
02000 PUSHJ P,GFS ;GET SOME FREE STORAGE(WHILE IT LASTS!)
02100 HRLI T,400 ;MAKE BYTE PTR.
02200 MOVEM T,RELPTR(T1) ;PTR. FOR RELOCATION BITS.
02300 MOVEI T2,LOBUFS/12+2(T) ;LEAVE ROOM FOR REL. BITS
02400 HRRM T2,EMPTR(T1) ;DATA PTR.
02500 HRRZM T,@OBPTR(T1) ;FIX UP FORWARD LINKS.
02600 HRRZM T,OBPTR(T1)
02700 SETZM @OBPTR(T1)
02800 MOVNI LOBUFS-LOBUFS/12-3
02900 MOVEM BUFCNT(T1) ;SET UP WORD COUNT.
03000 POPJ P,
03100
03200 EMPTR: POINT 36,0,35 ;DATA OUTPUT POINTERS.
03300 EMIPTR: POINT 36,0,35
03400 EMVPTR: POINT 36,0,35
03500 RELPTR: POINT 4,0 ;RELOC. BITS PTRS.
03600 RELIPT: POINT 4,0
03700 RELVPT: POINT 4,0
03800
03900 OBPTR: BLOCK 3 ;PTR. TO FIRST WORD OF CURRENT BUFFER FOR
04000 ; USE IN FIXING UP FORWARD LINKS.
04100 BUFCNT: BLOCK 3 ;WORD COUNTS FOR BUFFERS.
04200
04300 FCBUF: 0 ;PTR. TO FIRST BUFFER IN EACH CHAIN.
04400 FICBUF: 0
04500 FVCBUF: 0
04600
04700 GFS: ADD T,JOBSYM ;DECREMENT BOTTOM OF FREE STORAGE.
04800 HRRZ JOBFF
04900 CAIL (T) ;ROOM LEFT ?
05000 ERROR (STORAGE FULL) ;NO.
05100 MOVEM T,JOBSYM
05200 POPJ P,
00100 ;THIS HERE IS THE COMPILER !
00200 ; RECURSIVE EXPRESSION ANALYZER.
00300
00400 SEXPR: PUSHJ P,SCAN
00500 EXPR: PUSHJ P,TERM ;<EXPR> = <TERM> ! <TERM><ADDOP><EXPR>
00600 EXPR1: TLNE A,DF ;A DELIMITER NEXT ?
00700 TLNN A,ADDBIT ;YES. AN ADD OR SUBTRACT OP. ?
00800 POPJ P, ;NO.
00900 PUSH P,A ;YES. LOOK FOR ANOTHER TERM.
01000 PUSHJ P,STERM ;THIS IS ITERATIVE INSTEAD OF
01100 ; RECURSIVE IN ORDER TO PROCESS FROM LEFT TO
01200 EXCH A,(P) ; RIGHT.
01300 PUSHJ P,(A) ;CALL APPROPRIATE GENERATOR.
01400 POP P,A
01500 JRST EXPR1
01600
01700 STERM: PUSHJ P,SCANV
01800 TERM: PUSHJ P,FACTOR ;<TERM>=<FACTOR>!<FACTOR><MULOP><FACT.>
01900 TERM1: TLNE A,DF ;A DELIMITER NEXT ?
02000 TLNN A,MULBIT ;YES. A MULTIPLY OR DIVIDE OP ?
02100 POPJ P, ;NO.
02200 PUSH P,A
02300 PUSHJ P,SFACTOR
02400 EXCH A,(P)
02500 PUSHJ P,(A)
02600 POP P,A
02700 JRST TERM1
02800
02900 SFACTOR:PUSHJ P,SCANV
03000 FACTOR: JRST PRIMARY ;GOOD ENOUGH FOR NOW ...
03100
03200 SPRIM: PUSHJ P,SCAN
03300 PRIMARY:
03400 JUMPE A,UDIERR ;STILL UNDEFINED ?
03500 TLNN A,DF ;IS IT A SPECIAL CHAR. ?
03600 JRST PRIM3 ;NO.
00100 PRIM2: CAMN A,MINV ;UNARY MINUS ?
00200 JRST PRUMIN ;YES.
00300 CAME A,LPARV ;NO. IT BETTER BE A (.
00400 ERROR (ILLEGAL PRIMARY.)
00500 PUSHJ P,SEXPR ;SCAN AN EXPRESSION.
00600 CAME A,RPARV ;LOOK FOR MATCHING PAREN.
00700 ERROR (MISSING RIGHT PAREN.)
00800 JRST SCAN ;SCAN AND RETURN.
00900
01000 PRUMIN: PUSHJ P,SPRIM ;UNARY MINUS; SCAN A PRIMARY.
01100 PUSH P,A
01200 PUSHJ P,UMGEN ;CALL GENERATOR.
01300 JRST POPAJ ;RESTORE A AND RETURN.
01400
01500 PRIM3: TLNN A,FUNBIT ;THE NAME OF A FUNCTION ?
01600 JRST SVRBL ;NO.
01700 PRFUN: PUSHJ P,FUNCAL ;COMPILE THE FUNCTION CALL.
01800 PUSHJ P,MRKAC0 ;MARK AC0 FULL (VALUE OF FUNCTION).
01900 JRST SCAN ;RETURN.
02000
02100 SVRBL: TLNN A,VRBLBT!SWVBT!NUMFLG!FOOBIT ;SHOULD BE A VARIABLE,ARRAY NAME,NUMBER OR FOO SYM.
02200 ERROR (ILLEGAL PRIMARY)
02300 TLNE A,VRBLBT!NUMFLG!FOOBIT ;IS IT AN ARRAY NAME ?
02400 JRST SVRBL2 ;NO.
02500 HRR A,(A) ;YES. GET R. HALF OF GOOD BITS.
02600 SUBI A,2 ;MAKE IT POINT TO ARRAY[-2].
02700 SVRBL2: PUSH OSP,A ;MAY BE AN ASN. STMT....
02800 TLNE A,NUMFLG+SWVBT ;IF IT IS A NUMBER, IT CAN'T BE
02900 JRST SCAN ;LEFT PART OF ASN. STMT.
03000 SVRBL1: PUSHJ P,SCAN ;GET LEFT ARROW,IF ANY.
03100 CAME A,LARV ;IT IS ONE, ISN'T IT ?
03200 LAROW: POPJ P, ;NOPE. JUST A GARDEN VARIETY VARIABLE.
03300 PUSHJ P,ASTMT1 ;YES. COMPILE IT.
03400 PUSHJ P,MRKAC ;SINCE ITS A PRIMARY, REMEMBER ITS
03500 JRST POPAJ ;VALUE, THEN RETURN.
03600 ASTMT1: ;; COMPILE ASSIGNMENT STMT...
03700 PUSHJ P,SEXPR ;COMPILE RIGHT PART OF STMT.
03800 EXCH A,(P) ;SAVE 'A' UNDERNEATH RETURN ADR.
03900 PUSH P,A
04000 JRST ASNGEN ;GENERATE THE STORE.
00100 ; PROCESS A FUNCTION CALL.
00200
00300 FUNCAL: PUSH P,RLOC ;SAVE R-TIME CODE LOC. CTR.
00400 HRRZ B,(A) ;GET PTR. TO PARAMETER DESCRIPTORS.
00500 PUSH P,B ;PTR. TO SYMTABLE ENTRY.
00600 PUSH OSP,(B) ;PLACE CALLING INSTR. ON OPND. STK.
00700 PUSH P,[POINT 6,0,35] ;MAKE A PTR. TO THE BYTES
00800 HRRM B,(P) ; OF THE PARAMETER DESRIPTION.
00900 ILDB T,(P) ;GET PARAMTER COUNT.
01000 PUSH P,T
01100 JUMPE T,FNOPR ;IF NO PARAMS., CALL GENERATOR.
01200 PUSHJ P,SCAN ;SWALLOW LEFT PAREN.
01300 CAME A,LPARV ;I HATE PEOPLE WHO DO THIS.
01400 ERROR (MISSING LEFT PAREN.)
01500 PUSHJ P,SCAN ;SCAN FIRST PARAM.
01600 FUNC4: PUSH P,A
01700 FUNC1: ILDB T,-2(P) ;GET NEXT PARAM. DESCRIPTOR.
01800 CAIN T,FDPARB ;IS IT A DUMMY PARAM. ?
01900 JRST FDPAR ;YES.
02000 CAIN T,FDPARC ;OR A TYPE 2 DUMMY ?
02100 JRST FDPAR2 ;YES.
02200 POP P,A ;NO.
02300 JUMPE T,FLPAR ;IF =0,NO MORE PARAMS.
02400 CAME A,RPARV ;NO PARENTHESES OR COMMAS HERE, PLEASE.
02500 CAMN A,COMMAV
02600 ERROR (MISSING PARAMETER)
02700 CAIN T,FAOPAR ;MUST THIS PARAM. BE AN ARRAY NAME ?
02800 JRST FAPAR ;YES.
02900 PUSHJ P,EXPR ;NO, LET IT BE AN EXPRESSION.
03000 FUNC2: CAMN A,COMMAV ;IS IT A COMMA ?
03100 FUNC3: PUSHJ P,SCAN ;YES, ALTHOUGH WE DONT REALLY CARE.
03200 JRST FUNC4
03300
03400 FLPAR: CAME A,RPARV ;LAST PARAM. IS FOLLOWED BY ).
03500 ERROR (MISSING RIGHT PAREN.) ; ... OR ELSE.
03600 FNOPR: PUSHJ P,GFUNC ;CALL GENERATORS.
03700 ILDB A,-1(P) ;GET NO. OF AC CONTAINING RESULT.
03800 SUB P,[XWD 4,4] ;FORGET ABOUT THINGS IN STACK.
03900 POPJ P,
04000
04100 FAPAR: ;PARAMETER IS NAME OF FUNCTION ARRAY.
04200 PUSHJ P,GAPAR ;CALL GENERATOR.
04300 PUSHJ P,SCAN
04400 JRST FUNC2
04500
04600 FDPAR: PUSHJ P,GDPAR ;GENERATE A DUMMY PARAM.
04700 JRST FUNC1
04800 FDPAR2: PUSH OSP,[0] ;EMIT A DUMMY PARAM., BUT WITHOUT
04900 JRST FUNC1 ;ANY INSTR. TO ZERO IT AT I-TIME.
00100 ; HERE ARE THE GLORIOUS, SUPER-INTELLIGENT, SCHIZOPHRENIC
00200 ; CODE GENERATORS. LOOK UPON THEM AND BE AMAZED.
00300
00400 MULGEN: SKIPA T,[FMP] ;GENERATE A MULTIPLY.
00500 ADDGEN: MOVSI T,(<FAD>) ;SEE THE STUPID FAIL !
00600 PUSH P,T
00700 PUSHJ P,GGET1 ;GET ONE OPERAND IN AN AC.
00800 GEN1: POP P,C ;RECOVER THE OPCODE.
00900 GEN2: PUSHJ P,EMINST ;EMIT THE INSTRUCTION.
01000 JRST MRKAC ;MARK THE AC FULL AND RETURN.
01100
01200 DIVGEN: SKIPA T,[FDV] ;GENERATE A DIVIDE ...
01300 SUBGEN: MOVSI T,(<FSB>) ; .. OR A SUBTRACT.
01400 PUSH P,T
01500 PUSHJ P,GGET2 ;GET FIRST OPERAND IN AN AC.
01600 JRST GEN1
01700
01800 UMGEN: PUSHJ P,GMURKA ;UNARY MINUS. GET THE OPERAND.
01900 PUSH P,E
02000 PUSHJ P,GETAC ;GET A FREE AC.
02100 POP P,B ;BRING BACK AC ADDRESS.
02200 MOVSI C,(<MOVN>) ;EMIT GOOD INSTRUCTION.
02300 JRST GEN2
02400
02500 MULOP←←MULGEN
02600 ADDOP←←ADDGEN
02700 SUBOP←←SUBGEN
02800 DIVOP←←DIVGEN
02900
03000 ASNGEN: ;COMPILE STORE FOR ASIGNMENT STMT.
03100 ASNOP: PUSH P,-1(OSP) ;SAVE PTR. TO GOOD BITS OF VRBL.
03200 PUSHJ P,GMURK ;GET EXPR. AND LEFT-PART VARIABLE.
03300 EXCH D,E ;GET THEM IN RIGHT ORDER.
03400 PUSHJ P,GG2 ;GET EXPR. IN AN AC.
03500 POP P,T ;RECOVER PTR. TO VRBL. GOOD BITS WORD...
03600 MOVE H
03700 LSH =35-PRVBT ;PUT R-TIME FLAG IN RIGHT POSITION...
03800 TLNN B,GPBIT ;IF NOT A P-SYMBOL,
03900 ORM (T) ;SET R-TIME BIT CORRECTLY.
04000 MOVSI C,(<MOVEM>) ;EMIT A MOVEM TO STORE VALUE OF EXPR.
04100 JRST EMINST
04200
00100 ; HA! I BET YOU THOUGHT WE WERE DONE, DIDN'T YOU ?
00200
00300 ; WELL, HERE BEGINS AN INFINITE REGRESSION OF
00400 ; CLEVER ,GRUBBY ROUTINES WHICH DO THE
00500 ; DIRTY WORK FOR THE GENERATORS.
00600
00700 ; GPONDER REMOVES THE TOP THING FROM THE OPERAND STACK,
00800 ; LOVINGLY PATS ITS MAGIC BITS INTO STANDARD FORMAT,
00900 ; AND SETS A FLAG INDICATING WHETHER IT IS AN
01000 ; R-TIME VARIABLE OR NOT.
01100
01200 GPONDER: MOVEI H,0 ;RESET R-TIME VARIABLE FLAG.
01300 GPOND1: POP OSP,T ;GET TOP THING.
01400 TLNE T,FOOBIT ;IS IT A FOO-SYMBOL?
01500 JRST GPFOO ;YES.
01600 TLNE T,NUMFLG ;A NUMBER ?
01700 POPJ P, ;YES. WE ARE DONE.
01800 TLNE T,SRACBT+RVBT ;AN R-TIME AC OR VARIABLE ?
01900 MOVEI H,1 ;YES. SET R-TIME FLAG.
02000 TLNE T,SRACBT ;AN R-TIME AC ?
02100 SETZM RACS(T) ;YES. MARK IT FREE.
02200 TLNE T,SIACBT ;(SAME FOR I-TIME AC).
02300 SETZM IACS(T)
02400 TLNE T,VRBLBT ;A VARIABLE ?
02500 HRR T,(T) ;YES. GET RT. HALF GOOD BITS.
02600 POPJ P,
02700 GPFOO: TRZE T,400000 ;IS IT A P-SYMBOL?
02800 JRST GPONP ;YES.
02900 GPONU: MOVEI H,1 ;REFERS TO A UINIT GENERATOR; SET FLG.
03000 HRRZS T ;GET NO. OF UNIT GEN.
03100 CAMLE T,UOPTR ;NO FORWARD REFERENCES TO UNIT GEN.
03200 ERROR (FORWARD REF. TO UNIT GENERATOR)
03300 MOVE T,UOTBL(T) ;GET ADDRESS OF ITS OUTPUT CELL.
03400 POPJ P,
03500
03600 GPONP:
03700 ADDI T,PBASE ;BASE OF PARAM. ARRAY.
03800 HRLI T,GPBIT ;MARK AS P-SYMBOL.
03900 POPJ P,
04000
00100 ; GMURK CLEVERLY GPONDERS THE TOP TWO OPERANDS,
00200 ; AND IF ONE OF THEM IS AN R-TIME VARIABLE
00300 ; AND THE OTHER IS AN I-TIME AC OR A P-SYMBOL, IT STORES
00400 ; THE LATTER WHERE IT WILL BE SAFE UNTIL R-TIME.
00500
00600 GMURKA: MOVEI H,0
00700 GMURK1: TDZA T,T ;PROCESS ONLY TOP STACK ELEMENT.
00800 GMURK: PUSHJ P,GPONDER ;GPONDER THE FIRST OPERAND.
00900 PUSH P,T ;SAVE IT
01000 PUSHJ P,GPOND1 ;NOW THE SECOND.
01100 POP P,D ;PUT THEM BOTH IN SOME SAFE ACCUMULATORS.
01200 MOVE E,T
01300 SKIPN H ;IS EITHER ONE AN R-TIME VARIABLE ?
01400 POPJ P, ;NO.
01500 TLNE E,SIACBT+GPBIT ;AN I-TIME AC OR A P-SYMBOL ?
01600 JRST GM2 ;YES.
01700 TLNN D,SIACBT+GPBIT ;HOW ABOUT THIS ONE ?
01800 POPJ P, ;HE ISN'T, EITHER. RETURN.
01900 SKIPA F,[EXP D] ;BAGBITING MACROX.
02000 GM2: MOVEI F,E ;SEE THE TWO HEADED MONSTER.
02100 MOVE A,(F) ;GET THE RELEVANT THING.
02200 TLNE A,GPBIT ;A P-SYMBOL, OR AN I-TIME AC ?
02300 JRST GM3 ; A P-SYMBOL.
02400 MOVE B,VLOC ;STORE IT IN VARIABLE AREA.
02500 GM3B: MOVEM B,(F) ;CHANGE THE OPERAND INDICATOR.
02600 MOVE C,[MOVEM EMICDI] ;EMIT THE STORE INSTRUCTION.
02700 PUSHJ P,EMINST
02800 JRST EMDV ;MAKE APLACE IN THE VARIABLES FOR IT.
02900
03000 GM3: SKIPN T1,(A) ;HAS THE PARAMETER ALREADY BEEN
03100 JRST GM3A ; PUT IN VAR. AREA ?
03200 MOVEM T1,(F) ;YES. CHANGE POINTER.
03300 POPJ P,
03400
03500 GM3A: PUSHJ P,GETIAC ;FIND FREE I-TIME AC.
03600 MOVE B,(F)
03700 MOVE T,VLOC ;GET VAR. LOC. CTR.
03800 TLO T,GPBIT
03900 MOVEM T,(B) ;ENTER IN PARAMTER TABLE.
04000 MOVE C,[MOVE EMICDI] ;EMIT INSTR. TO
04100 PUSHJ P,EMINST ;PICK UP THE PARAMETER.
04200 MOVE B,VLOC ;GET LOC. AGAIN...
04300 TLO B,GPBIT ;MARK AS A P-SYMBOL.
04400 JRST GM3B ;NOW STORE THE PARAMETER IN VAR. AREA.
04500
00100 ; STILL MORE KLUGES. PAUSE TO GET YOUR BREATH NOW.
00200
00300 ;GGET1 ARRANGES TO HAVE ONE OF THE TOP TWO OPERANDS
00400 ; IN AN AC. IT RETURNS IN 'A' THE ADDRESS OF THAT AC, AND
00500 ; IN 'B' THE ADDRESS OF THE OTHER OPERAND, WITH RELOCATION
00600 ; BITS IN LEFT HALF.
00700
00800 GGET1: PUSHJ P,GMURK ;PROCESS TOP TWO OPERANDS.
00900 TLNN D,SIACBT+SRACBT ;IS FIRST ONE IN AN AC ?
01000 JRST GG2 ;NO.
01100 MOVE A,D ;YES. WE ARE DONE.
01200 MOVE B,E
01300 POPJ P,
01400 GGET2: PUSHJ P,GMURK ;GGET2 GETS SECOND OPERAND IN AN AC.
01500 GG2: MOVE A,E ;PUT OPERAND IN A.
01600 TLNE A,SIACBT+SRACBT ;IS IT ALREADY IN AN AC ?
01700 JRST GL2A ;YES. WIN BIG.
01800 TLNE D,SIACBT+SRACBT ;HOW ABOUT OTHER OP. ?
01900 SETOM @ACTB3(H) ;AN AC... MARK IT FULL TEMPORARILY.
02000 PUSHJ P,GETAC ;GET A FREE AC OF THE APPROPRIATE KIND.
02100 MOVE B,E ;LOAD SECOND OPERAND INTO IT.
02200 MOVSI C,(<MOVE>) ;EMIT LOAD INSTR.
02300 PUSHJ P,EMINST
02400 TLNE D,SIACBT+SRACBT ;IF OTHER OP. IS IN AN AC,
02500 SETZM @ACTB3(H) ;MARK IT FREE NOW.
02600 GL2A: MOVE B,D ;PUT OTHER OP IN B.
02700 POPJ P,
02800
02900 ; EMINST IS THE INSTRUCTION EMITTING ROUTINE. CALL IT
03000 ; WITH AC IN A,THE ADDRESS (+ RELOC. BITS) IN B, AND
03100 ; OPCODE IN C. IF RIGHT HALF OF C IS NON-ZERO, IT IS THE
03200 ; ADDRESS OF THE APPROPRIATE BUFFER EMITTING ROUTINE;
03300 ; OTHERWISE THE INSTR. IS PLACED IN THE I-TIME
03400 ; OR R-TIME BUFFERS ACCORDING TO THE STATE OF THE FLAG IN H.
03500
03600 EMINST: PUSH P,A ;SAVE IT.
03700 HLL A,C ;ASSEMBLE INSTRUCTION IN A.
03800 DPB A,[POINT 4,A,12] ;PUT IN AC FIELD.
03900 HRR A,B ;ALSO ADDRESS.
04000 TLZE B,FPARBT ;IS ADDR. A FORMAL PARAMETER ?
04100 TLO A,20+RA ;YES. ADD INDIRECT BIT AND INDEX.
04200 HLRZS B ;PUT RELOC. BITS FOR ADDRESS IN RIGHT HALF OF B.
04300 PUSH P,[EXP EMIN2] ;RETURN ADDRESS.
04400 TRNE C,-1 ;RH OF C =0 ?
04500 JRST (C) ;NO.
04600 JRST @EMITB(H)
04700 POPAJ: ;A USEFUL ENTRY POINT.
04800 EMIN2: POP P,A
04900 POPJ P,
05000 EMITB: EMICDI
05100 EMCDI
05200 ACTB3: XWD D,IACS
05300 XWD D,RACS
00100 ;GETAC SEARCHES FOR A FREE AC, EITHER I-TIME OR
00200 ; R-TIME, AS INDICATED BY THE STATE OF THE FLAG IN H.
00300
00400 GETAC: SKIPE H ;ARE WE EMITTING R-TIME CODE ?
00500 GETRAC: SKIPA T3,[XWD SRACBT+A,RACS] ;YES, FIND A R-TIME AC.
00600 GETIAC: MOVE T3,[XWD SIACBT+A,IACS] ;FIND AN I-TIME AC.
00700 MOVE A,[XWD -NACS,NFACS] ;CONSIDER ONLY AC'S 4-14
00800 TRNE FL,CSBRBT ; ..UNLESS WE'RE COMPILING A FUNCTION..
00900 MOVE A,[XWD -NFACS,0] ;WE ARE. CONSIDER ONLY 0-3.
01000 SKIPE @T3 ;INDIRECT ADDRESSING IS GOOD FOR YOU.
01100 AOBJN A,.-1 ;NOT FREE. TRY FOR NEXT ONE.
01200 JUMPLE A,GETAC3 ;DID WE FIND ONE ?
01300 PUSHJ P,GETAC2 ;NO. STORE ONE.
01400 GETAC3: HRLI A,SRACBT ;YES. PUT IN APPROPRIATE FLAG BITS.
01500 TLNN T3,SRACBT ;OOPS, IT'S AN I-TIME AC.
01600 HRLI A, SIACBT
01700 POPJ P,
01800
01900 GETAC2: SUBI A,1 ;STORE HIGHEST AC.
02000
02100 GSVAC: MOVE T,@T3 ;FIND OUT WHO'S IN HIM.
02200 MOVE B,VLOC ;GET LOC. TO STORE HIM IN.
02300 MOVEM B,(T) ;FIX UP HIS STACK ENTRY.
02400 SETZM @T3 ;MARK HIM EMPTY.
02500 MOVSI C,(<MOVEM>) ;EMIT THE STORE INST.
02600 PUSHJ P,EMINST
02700 JRST EMDV ;LEAVE A PLACE IN VARIABLES AREA.
02800
02900 ;MRKAC PUTS THE AC SYMBOL IN A BACK ON THE STACK AND MARKS
03000 ; THE CORRESPONDING AC AS FULL.
03100
03200 MRKAC0: IOR A,MRKTAB(H) ;MARK IAC 1 OR RAC 1 FULL.
03300
03400 MRKAC: PUSH OSP,A ;PUT IT ON STACK.
03500 TLNN A,SRACBT ;AN R-TIME AC?
03600 HRRZM OSP,IACS(A) ;NO, MARK CORRESPONDING I-TIME AC FULL.
03700 TLNE A,SRACBT
03800 HRRZM OSP, RACS(A)
03900 CPOPJ: POPJ P,
04000
04100 MRKTAB: XWD SIACBT,0 ;DESCRIPTOR FOR I-TIME AC NO. 1
04200 XWD SRACBT,0 ;R-TIME AC 1.
04300
00100 ;; MORE GENERATORS.
00200
00300 GAPAR: ;; HANDLE A PARAMETER WHICH IS AN ARRAY NAME.
00400 TLNE A,SWVBT ;IS IT AN ARRAY IDENTIFIER OR
00500 HRR A,(A)
00600 TLNE A,FPARBT+SWVBT ; A FORMAL PARAMETER ?
00700 JRST GAPR1 ;YES.
00800 TLNE A,FOOBIT ;BETTER BE A FOO-SYMBOL, THEN....
00900 TRZN A,400000 ;FURTHERMORE, IT MUST BE A P-SYM.
01000 ERROR(IMPROPER ARRAY PARAMETER)
01100 PUSH P,A ;SAVE P NO.
01200 PUSHJ P,GETIAC ;FIND FREE I-TIME AC.
01300 POP P,B
01400 ADDI B,PBASE ;CALC. ADDR. OF P-SYMBOL.
01500 MOVE C,[MOVE EMICDI] ;EMIT MOVE AC,P-SYMBOL TO THE
01600 PUSHJ P,EMINST ;I-TIME CODE STREAM.
01700 HRLI A,(<MOVEM>) ;NOW A MOVEM AC, INTO THE PARAMETER
01800 DPB A,[POINT 4,A,12] ;LOCATION.
01900 TRZA A,-1 ;CLEAR ADDRESS FIELD.
02000 GDPAR: MOVSI A,(<SETZM>) ;PARAM. LIST AT I-TIME.
02100 PUSH OSP,ILOC ;PUT ARRAY MARKER IN OPERAND
02200 MOVSI T,SWVBT+FPARBT ;STACK SO A FIXUP CAN BE EMITTED TO
02300 IORM T,(OSP) ;THE UPCOMMING HRRM WHEN THE PARAMETERS
02400 MOVEI B,0 ;NO RELOCATION, PLEASE.
02500 JRST EMICDI ;EMIT HRRM TO STORE ARRAY LOC. INTO
02600 ;PARAMETER CELL, AND RETURN.
02700 GAPR1: PUSH OSP,A ;PLACE IN OPERAND STACK.
02800 POPJ P,
00100 GFUNC: ;; GENERATE A FUNCTION CALL.
00200 MOVE A,@-3(P) ;PICK UP THE CALLING INSTR. FOR THE FUNCTION.
00300 MOVE D,RLOC ;DECIDE WHETHER CALL IS TO BE IN
00400 MOVEI H,0 ;R-TIME OR I-TIME CODE.
00500 TLZN A,20 ;IND. BIT IN INSTR. SAYS R-TIME ALWAYS.
00600 CAME D,-4(P) ;ALSO R-TIME IF ANY R-TIME PARAMETERS
00700 MOVEI H,1 ;HAVE BEEN COMPILED.
00800 GFUNC8: MOVE T3,ACTB1(H)
00900 MOVSI A,-NFACS ;PREPARE TO SEARCH AC'S 0-4.
01000 SKIPN T,@T3 ;IS THIS ONE IN USE ?
01100 AOBJN A,.-1 ;NO.
01200 JUMPG A,GFUNC6 ;DID WE FIND A BUSY ONE ?
01300 PUSHJ P,GSVAC ;YES. SAVE IT.
01400 JRST GFUNC8
01500 GFUNC6: PUSH P,-1(P) ;PUT PAR. COUNT ON STACK.
01600 HRRZM P,TEMP1# ;SAVE LOC. OF COUNT.
01700 GFUNC5: SOSGE @TEMP1 ;MORE PARAMS ?
01800 JRST GFUNC4 ;NO.
01900 PUSHJ P,GMURK1 ;GET A PARAM.
02000 TLNN E,SWVBT
02100 TLNN E,FPARBT ;IS IT A FORMAL PARAMETER ?
02200 JRST GFUNC7 ;NO, THANK GOD.
02300 MOVE A,E ;SIGH. THE PRICE OF HONESTY ...
02400 HRLI A,(<MOVE (RA)>) ;EMIT CODE TO PICK UP THE
02500 MOVEI B,0 ;PARAM. PTR. AND PUT IT IN THE
02600 PUSHJ P,@EMITB(H) ;CURRENT CALLING SEQUENCE.
02700 MOVE E,ILOC(H) ;SAVE ILOC OR RLOC FOR LATER FIXUP.
02800 TLO E,FPARBT ;MIGHT AS WELL USE THIS BIT...
02900 MOVSI A,(<MOVEM>) ;NOW THE SECOND INSTR....
03000 PUSHJ P,@EMITB(H)
03100 GFUNC7: PUSH P,E ;SAVE IT.
03200 JRST GFUNC5 ;GET ANOTHER.
03300 GFUNC4: POP OSP,A ;NOW EMIT THE CALLING INSTR.
03400 GFUNC2: LDB B,[POINT 4,A,17] ;RELOC. BITS.
03500 TLZ A,37
03600 TLZE A,SWVBT ;IS IT AN ARRAY NAME ?
03700 TLO A,INSXR ;YES. ADD INDEX FIELD.
03800 GFUNC3: PUSHJ P,@EMITB(H) ;
03900 POP P,A ;GET PARAM. FROM STACK.
04000 JUMPL A,CPOPJ ;IF IT'S THE MARK, RETURN.
04100 TLZN A,FPARBT ;IS IT A FORMAL PARAMETER ?
04200 JRST GFUNC2 ;NO. EMIT IT.
04300 MOVEI B,.FXBTS ;YES. EMIT A FIXUP TO THE RIGHT INSTRUCTION.
04400 TLZ A,400000+LRFXBT+SWAPBT ;A REPLACEMENT FIXUP TO RT. HALF.
04500 TLO A,RRFXBT
04600 PUSHJ P,@EMITB2(H) ;EMIT IT TO I-TIME OR R-TIME BUFER.
04700 MOVEI B,0 ;NOW RESERVE SPACE FOR THE PARAM.
04800 JRST GFUNC3
04900 EMITB2: EMICD
05000 EMCD
05100 ACTB1: XWD SIACBT+A,IACS ;PTR. TO IACS,INDEXED BY B.
05200 XWD SRACBT+A,RACS
00100 ;; UTILITY RUOTINE TO ENTER AN ITEM IN THE MAIN SYMBOL TAB.
00200
00300 GETNAM: PUSHJ P,SCANV ;SCAN AN IDENTIFIER.
00400 GETNM1: AOS T,(P) ;TO SKIP PARAM ON RETURN.
00500 JUMPE A,GNM2 ;SHOULD BE UNDEFINED...
00600 TLOE A,DF ;IT'S NOT. MAYBE IT'S A DELIMITER ?
00700 ERROR (MISSING IDENTIFIER)
00800 TLNN A,@-1(T) ;NO. MAYBE ALREADY RIGHT TYPE ?
00900 ERROR (MULTIPLY DEFINED SYMBOL)
01000 SKIPGE -1(T) ;AH, IT IS. SHOULD WE REENTER IT ?
01100 POPJ P, ;NO. ITS OLD ENTRY WILL DO.
01200 GNM2: HRLZ A,-1(T) ;YES. GET TYPE BITS.
01300
01400 AENTER: HRRZ JOBFF ;GET NEXT FREE LOCATION.
01500 HRRZ B,CBNO ;GET BUCKET NO. OF THING JUST SCANNED.
01600 EXCH BUCTBL(B) ;UPDATE BUCKET HEAD.
01700 AOS B,JOBFF
01800 MOVEM -1(B) ;PUT THE LINK IN THE NEW ENTRY.
01900 MOVEM A,1(B) ;PUT THE RANDOM GOOD BITS IN.
02000 MOVE ACCUM ;GET FIRST WORD OF NAME.
02100 MOVEM (B) ;PUT IN TABLE.
02200 AOS B,JOBFF
02300 MOVEI T,ACCUM+1 ;PREPARE TO MOVE REST OF NAME.
02400 AEL1: AOS JOBFF
02500 SKIPN T1,(T) ;ANY MORE OF THE NAME ?
02600 JRST AEL2 ;NO.
02700 MOVEM T1,@JOBFF ;YES. PUT IN TABLE.
02800 CAIL T,ACCUM+2 ;UNLESS FIRST OR SECOND WORD,
02900 SETZM (T) ;ZERO WORD IN ACCUM.
03000 AOJA T,AEL1
03100 AEL2: HRRZ JOBSYM ;GET BOTTOM OF BUFFER AREA.
03200 CAMG JOBFF ;HAVE WE OVERRUN IT ?
03300 ERROR(CORE IS FULL)
03400 HRR A,B
03500 HRRZ JOBFF
03600 HRLM JOBSA
03700 POPJ P,
03800
00100 ;; INITIALIZATION OF THE COMPILER.
00200
00300 EXTERNAL JOBFF,JOBSA
00400 JOBSYM: 0
00500
00600 SCOMPA: MOVE OSP,[XWD -LOSTK,OSTK-1] ;INIT. OPERAND STACK.
00700 PUSH OSP,JOBSYM ;...SO WE CAN RESTORE IT LATER.
00800 MOVSI IRELBT ;INIT THE THREE LOCATION
00900 MOVEM ILOC ;COUNTERS (APPROPRIATE RELOCATION
01000 MOVSI RRELBT ;BITS LIVE IN LEFT HALF OF EACH).
01100 MOVEM RLOC
01200 MOVSI VRELBT
01300 MOVEM VLOC
01400 MOVEI T1,2 ;SET UP THE THREE CHAINS OF OUTPUT
01500 SCMP1: SETZM OBPTR(T1)
01600 PUSHJ P,GBUF ;BUFFERS.
01700 HRRZM T,FCBUF(T1) ;PTR. TO FIRST BUFFER OF CHAIN
01800 SOJGE T1,SCMP1 ;DO FOR ALL THREE CHAINS.
01900 SETZM IARR1 ;ZERO SOME TABLES AND STUFF.
02000 MOVE [XWD IARR1,IARR1+1]
02100 BLT IARR2-1
02200 MOVEI FL,0 ;CLEAR FLAGS.
02300 POPJ P,
02400
02500 SCOMP: PUSHJ P,SCOMPA ;INIT. THE COMPILER.
02600 MOVE [XWD IARR2-1,IARR2]
02700 BLT IARR3-1 ;ZERO REST OF TABLES.
02800 POPJ P,
00100 ;; SYNTAX ANALYZER.
00200
00300 SSTATL: PUSHJ P,SMCSCN ;SCAN NEXT NON-SEMICOLON.
00400 STATL: CAMN A,FINV ;IS IT A FINISH ?
00500 JRST ENDP1 ;YES.
00600 PUSHJ P,STAT ;NO. SCAN A STATEMENT.
00700 JRST SSTATL ;GO BACK FOR MORE.
00800
00900 SSTAT: PUSHJ P,SMCSCN
01000 STAT: MOVEI H,0 ;CLEAR 'R-TIME CODE' FLAG.
01100 JUMPGE A,STAT2 ;A DELIMITER ?
01200 TLNE A,DECLBIT ;YES. A DECLARATION ?
01300 JRST (A) ;YES. DISPATCH TO RIGHT ROUTINE.
01400 STAT2: PUSHJ P,STMT1 ;IT HAS TO BE A STMT1.
01500 STATL1: CAME A,SEMICV ;SEMICOLON AFTER EVERY STMT.,PLEASE.
01600 ERROR (MISSING SEMICOLON) ;I HATE MYSELF FOR THIS.
01700 TDZ FL,[XWD ERRFLG,EXTFLG] ;TURN OFF ERROR FLAG.
01800 POPJ P, ;END OF STATEMENT.
01900
02000 EXTD: PUSHJ P,SCAN ;"EXTERNAL" DECLARATION.
02100 CAME A,FUNV ;BETTER BE "FUNCTION".
02200 ERROR (<EXTERNAL FUNCTIONS ONLY,PLEASE.>)
02300 TRO FL,EXTFLG ;SET FLAG.
02400 JRST DFUNC
02500
02600 SSTMT1: PUSHJ P,SCAN
02700 STMT1: SKIPN A ;IS IT UNDEFINED ?
02800 ERROR (UNDEFINED IDENTIFIER)
02900 STMT1A: TLNE A,FUNBIT ;<STMT1>=<FUNCTION CALL> ! <ASN. STMT>
03000 JRST SFUNC ;A FUNCTION CALL.
03100 TLNN A,VRBLBT!FOOBIT ;BETTER BE A SIMPLE VARIABLE.
03200 ERROR (SIMPLE VARIABLE REQUIRED HERE.)
03300 PUSH OSP,A ;STACK IT.
03400 PUSHJ P,SCAN ;GET LEFT ARROW.
03500 CAME A,LARV
03600 ERROR (ILLEGAL STATEMENT)
03700 PUSHJ P,ASTMT1 ;IT'S AN ASSIGNMENT STMT. COMPILE IT.
03800 JRST POPAJ ;RESTORE A(WHICH WAS SAVED BY ASTMT)
03900 ; AND RETURN.
04000 SFUNC: PUSHJ P,FUNCAL ;COMPILE FUNCTION CALL
04100 JRST SCAN ;RETURN.
04200
04300 SMSC1:
04400 SMCSCN: PUSHJ P,SCAN ;SCAN PAST NEXT SEMICOLON.
04500 SMCS1: CAMN A,SEMICV
04600 JRST SMCSCN
04700 POPJ P,
00100
00200 ENDSTL: RELEAS DT, ;ALL DONE. RELEAS INPUT DEVICE.
00300 ENDP1:
00400 MOVEI A,0
00500 MOVEI B,.FXBTS ;PUT END MARKS IN THE BUFFERS.
00600 PUSHJ P,EMCD
00700 PUSHJ P,EMICD
00800 PUSHJ P,EMVCD
00900 POP OSP,JOBSYM ;RESTORE JOBSYM.
01000 POPJ P,
01100 EXTERNAL JOBDDT,JOBREL
01200
01300 DVRBL1: CAME A,COMMAV ;IS IT A COMMA ?
01400 JRST STATL1 ;NO. END OF DECL.
01500 DVRBL: PUSHJ P,SCAN ;GET NEXT ITEM.
01600 CAMN A,CTBL+"/" ;IS IT A "/" ?
01700 JRST DVRBL2 ;YES. DEFINE FOLLOWING VARIABLE AS R-TIME.
01800 PUSHJ P,GETNM1 ;NO. MUST BE NAME OF VARIABLE. PUT IN SYM. TABLE.
01900 XWD 400000,VRBLBT ;PARAM. TO GETNM1.
02000 DVRBL4: JUMPL A,DVRBL3 ;WAS IT ALREADY DEFINED ?
02100 AOS A,JOBFF ;NO, IT'S NEW. LEAVE WORD FOR THE VALUE.
02200 SUBI A,1 ;GET PTR. TO THAT WORD.
02300 HRRM A,(B) ;PUT IN GOOD BITS WORD (NO REL. BITS).
02400 DVRBL3: PUSHJ P,SCAN ;GET COMMA OR SEMICOLON.
02500 JRST DVRBL1 ;BACK FOR MORE.
02600
02700 DVRBL2: PUSHJ P,GETNAM ;SCAN AND ENTER NAME OF VARIABLE.
02800 XWD 400000,VRBLBT!RVBT ;INCLUDE 'R-TIME' BIT.
02900 JRST DVRBL4
00100 DF5: CAME A,COMMAV ;ARE THERE MORE DEFINITIONS ?
00200 JRST STATL1 ;NO.
00300 DFUNC: TRO FL,CSBRBT+SFOOBT ;ENTER FUNCTION DEFINING MODE.
00400 PUSHJ P,GETNAM ;GET FUNCTION NAME.
00500 EXP FUNBIT ;PARAMETER TO GETNAM.
00600 PUSH P,BUCTBL ;####$$%%$ A TEMPORARY KLUGE !!
00700 MOVE A,JOBFF ;GET FIRST FREE STORAGE LOC.
00800 HRRM A,(B) ;MAKE GOOD BITS WORD POINT THERE.
00900 HRLI A,600 ;MAKE A INTO A BYTE POINTER.
01000 PUSH P,A
01100 PUSH P,A
01200 IBP (P) ;THIS POINTER IS FOR PARAMETER DESCRIPTORS.
01300 HRLI A,400000+LRFXBT+RRFXBT ;NOW EMIT FIXUP TO THE LOCATION IN THE SYM. TABLE WHICH WILL
01400 MOVEI B,.FXBTS ;CONTAIN THE CALLING INSTR. FOR THE FUNCTION, SO IT CAN BE UPDATED AT
01500 PUSHJ P,EMICD ;LOAD TIME WITH THE RELOCATED ADDRESS OF THE FUNCTION.
01600 ADDI A,5 ;LEAVE ENOUGH ROOM FOR 22 PARAMETER
01700 HRRZM A,JOBFF ;DESCRIPTORS.
01800 TRNN FL,EXTFLG ;IS IT AN EXTERNAL FUNCTION ?
01900 SKIPA A,ILOC ;NO. ADDRESS IS IN ILOC.
02000 PUSHJ P,SYMSCH ;YES. FIND STARTING ADDRESS.
02100 TLO A,(<JSA RA,>) ;MAKE INTO A CALLING INSTR.
02200 MOVEM A,@-1(P) ;PLACE IN SYM. TABLE.
02300 LDB B,[POINT 4,A,17] ;GET THE RELOCATION BITS.
02400 TLZ A,17 ;TURN THEM OFF IN THE INSTRUCTION WORD.
02500 PUSHJ P,EMICD ;EMIT AS VALUE OF ABOVE FIXUP.
02600 PUSH P,[-1] ;INIT. THE PARAMETER COUNT.
02700 PUSHJ P,SCAN ;LOOK AT NEXT THING.
02800 CAME A,LPARV ;A ( ?
02900 JRST DFNOPR ;NO. THERE ARE NO PARAMETERS.
03000 DF2: PUSHJ P,SCAN ;SCAN A PARAMETER.
03100 CAME A,ARRV ;IS IT AN ARRAY NAME ?
03200 JRST DF2A ;NO.
03300 TRO FL,ARRFLG ;YUP. SET FLAG AND GET NAME OF
03400 JRST DF2 ;PARAM.
00100 DF2A: TLNE A,DF+NUMFLG
00200 ERROR (ILLEGAL FORMAL PARAMETER)
00300 AOS A,(P) ;INCREMENT PARAMETER COUNT.
00400 HRLI A,FPARBT!VRBLBT ;MAKE A INTO FORMAL PARAM. INDICATOR
00500 PUSHJ P,AENTER ; AND ENTER THE SYMBOL.
00600 MOVEI 2 ;PUT 'ORDINARY' FLAG IN THE PARAMETER
00700 TRZE FL,ARRFLG ;AN ARRAY NAME PARAM. ?
00800 MOVEI 1 ;YES. USE RIGHT DESCRIPTOR BIT.
00900 IDPB -1(P) ;DESCRIPTOR FOR THIS PARAM.
01000 PUSHJ P,SCAN
01100 CAMN A,COMMAV ;A COMMA ?
01200 JRST DF2 ;YES LOOK FOR MORE PARAMETERS.
01300 CAME A,RPARV ;IT BETTER BE A ).
01400 ERROR (MISSING RIGHT PAREN.)
01500 PUSHJ P,SCAN ;GET THE =.
01600 MOVEI B,0 ;FLAG END OF PARAMETER DESCRIPTORS.
01700 IDPB B,-1(P)
01800 DFNOPR: TRNE FL,EXTFLG ;IS THIS AN EXTERNAL FUNCTION ?
01900 JRST DF4 ;YES. LOOK FOR NO DEFINITION.
02000 CAME A,CTBL+"="
02100 ERROR (MISSING = IN FUNCTION DEFINITION)
02200 PUSHJ P,EMICDI ;LEAVE ROOM FOR THE JSA WORD.
02300 TRZ FL,SFOOBT ;LET SCANNER SEE FOO-SYMBOLS AGAIN.
02400 PUSHJ P,SEXPR ;SCAN AN EXPRESSION.
02500 DF4: PUSH P,A
02600 TRNE FL,EXTFLG ;AN EXTERNAL ?
02700 SKIPA E,[XWD SIACBT,0] ;YES. RESULT ALWAYS IN 0.
02800 PUSHJ P,GMURK1 ;GET IT OFF STACK.
02900 PUSHJ P,GG2 ;MAKE SURE ITS IN AN AC.
03000 IDPB A,-2(P) ;TELL UNIVERSE WHICH AC .
03100 AOS B,-1(P) ;ADJUST PARAMETER COUNT.
03200 IDPB B,-3(P) ;PUT IN SYM. TABLE.
03300 MOVEI A,RA ;EMIT RETURN INSTR.
03400 MOVSI C,(<JRA RA,(RA)>)
03500 TRNN FL,EXTFLG ;...UNLESS THIS IS AN EXTERNAL.
03600 PUSHJ P,EMINST
03700 AOS A,-2(P) ;FIND TOP OF PARAM. DESC. STRING.
03800 HRRZM A,JOBFF ;RESET FREE STORAGE.
03900 HRLM A,JOBSA
04000 POP P,A
04100 SUB P,[XWD 3,3] ;FORGET JUNK IN STACK.
04200 POP P,BUCTBL ;##$$%$# MORE OF THAT KLUGE !!!
04300 TRZ FL,CSBRBT+SFOOBT ;LEAVE FUNCTION DEFINING MODE.
04400 JRST DF5 ;ALL DONE.
00100 ;; MORE SYNTAX ANALYZER. COMPILE AN INSTRUMENT DEFINITION.
00200
00300 CINS: PUSHJ P,GETNAM ;GET NAME OF INSTRUMENT.
00400 EXP INSBIT ;PARAMETER TO GETNAM.
00500 AOS A,JOBFF ;GET PLACE FOR MORE GOOD BITS..
00600 SUBI A,1
00700 HRRM A,(B) ;MAKE RANDOM BITS WORD POINT THERE.
00800 HRLI A,RRFXBT ;RIGHT HALF REPLACEMENT TYPE FIXUP.
00900 MOVEI B,.FXBTS ;EMIT FIXUP TO RIGHT HALF FROM
01000 PUSHJ P,EMICD ;FIRST LOC. OF I-TIME CODE.
01100 HRLI A,LRFXBT+SWAPBT ;FIXUP TO LEFT HALF FROM FIRST LOC.
01200 PUSHJ P,EMCD ;OF R-TIME CODE.
01300 CINS5: PUSHJ P,SCAN
01400 CINS3: PUSHJ P,SMCS1 ;IGNORE SEMICOLON, IF ANY.
01500 CAMN A,ENDV ;IS IT AN END ?
01600 JRST CINSE ;YES.
01700 TLNN A,UGBIT ;IS IT A UNIT GENERATOR CALL ?
01800 JRST CINS4 ;NOT A UNIT GENERATOR.
01900 HRRZM A,CINST1# ;SAVE IT.
02000 PUSHJ P,SCAN ;PEEK AT NEXT THING.
02100 CAMN A,CTBL+"[" ;IS IT A [ ?
02200 JRST CUG1 ;YES. UNIT GEN. HAS CONTROLLED CALLING RATE.
02300 MOVEM A,SNCHR ;NO, IT'S PROBABLY THE (. PUT IT BACK WHERE SCAN WILL SEE IT AGAIN.
02400 PUSHJ P,CINS6 ;NOW COMPILE THE CALL ON THE UNIT GEN.
02500 JRST CINS5 ;BACK FOR MORE.
02600
02700 CINS6: MOVE A,CINST1 ;RECOVER POINTER FOR USE OF FUNCAL.
02800 PUSHJ P,FUNCAL ;COMPILE CALL ON THE UNIT GEN.
02900 MOVE B,VLOC ;GET LOC. FOR OUTPUT OF UNIT GEN.
03000 AOS C,UOPTR ;INCREMENT COUNT OF UNIT GENS.
03100 MOVEM B,UOTBL(C) ;ENTER OUTPUT LOC. IN TABLE.
03200 MOVE C,[MOVEM EMCDI] ;EMIT STORE INSTRUCTION TO
03300 PUSHJ P,EMINST ;PUT OUTPUT OF UNIT GEN. AWAY.
03400 PUSHJ P,EMDV ;MAKE ROOM IN VARIABLES AREA FOR IT.
03500 MOVE T,@CINST1 ;RETRIEVE PTR. TO RANDOM GOOD BITS.
03600 SKIPN A,-1(T) ;DOES UNIT GEN. HAVE I-TIME CODE?
03700 POPJ P, ;NO.
03800 PUSHJ P,EMIABS ;YUP. EMIT THE CALLING INSTR.
03900 HRRZ A,RLOC ;AS PARAMETER, GIVE IT A PTR. TO
04000 MOVEI B,RRELBT ;JUST AFTER THE MOVEM EMITTED
04100 PUSHJ P,EMICDI ;ABOVE.
04200 POPJ P,
00100 CINS4: PUSHJ P,STMT1 ;ITS NOT A UNIT GEN. CALL.
00200 JRST CINS3 ;NO
00300 CINSE: SETZM IARR1 ;YES. ZERO THINGS.
00400 MOVE [XWD IARR1,IARR1+1]
00500 BLT IARR3-1
00600 MOVE A,[POPJ P,] ;PUT RETURN INSTR. AT END OF
00700 MOVEI B,0 ;THE I-TIME CODE.
00800 PUSHJ P,EMICDI
00900 PUSHJ P,EMCDI ;ALSO THE R-TIME CODE.
01000 CINSR1: PUSHJ P,SCAN
01100 JRST STATL1
01200
01300 ;; IF THE NAME OF A UNIT GENERATOR IS FOLLOWED BY AN
01400 ;; EXPRESSION IN SQUARE BRACKETS, THE U.G. GETS CALLED ONLY
01500 ;; EVERY N TIME STEPS, WHERE N IS THE VALUE OF THE EXPRESSION.
01600 ;; N IS RECALCULATED EVERY TIME THE U.G. IS CALLED.
01700
01800 CUG1: MOVE C,[AOSGE EMCDI] ;INSTR. TO COUNT NO. OF TIME STEPS TO SKIP THIS UG.
01900 MOVE B,VLOC ;GRAB LOCATION IN VARIABLE AREA TO HOLD COUNT OF TIME STEPS TO SKIP.
02000 MOVEI A,0 ;NO AC FIELD, PLEASE.
02100 PUSHJ P,EMINST ;EMIT THE AOSGE JUST AHEAD OF THE CODE TO CALL THE U.G.
02200 MOVE C,[SETZM EMICDI] ;ALSO EMIT AN INSTR. TO THE I-TIME
02300 MOVE B,VLOC ;CODE TO INIT. THE COUNTER LOCATION TO 0 (SO U.G. GETS CALLED FIRST TIME).
02400 PUSHJ P,EMINST
02500 PUSH P,RLOC ;SAVE R-TIME LOC. COUNTER (FOR LATER FIXUP TO JRST WE ARE ABOUT TO EMIT).
02600 PUSH P,VLOC ;ALSO VARIABLE LOC., FOR LATER LOADING OF THE STEPS-TO-SKIP COUNTER.
02700 PUSHJ P,EMDV ;MAKE A WORD FOR IT.
02800 MOVSI A,(<JRST>) ;NOW EMIT THE JUMP AROUND THE CALL OF
02900 PUSHJ P,EMCDI ;THE U.G. !!"" N.B.: B IS 0 HERE FROM CALL ON EMDV !!
03000 PUSHJ P,SEXPR ;NOW COMPILE THE EXPRESSION IN THE BRACKETS.
03100 CAME A,CTBL+"]" ;SHOULD BE FOLLOWED BY ONE...
03200 ERROR (MISSING ])
03300 MOVEI H,1 ;INDICATE THAT WE ARE WORKING WITH R-TIME CODE...
03400 PUSHJ P,GMURK1 ;..AND GET EXPR OFF OPERAND STACK.
03500 PUSHJ P,GG2 ;NOW GET IT INTO AN AC.
03600 MOVSI C,(<FIX>) ;EMIT INSTR. TO FIX VALUE OF EXPRESSION.
03700 MOVEI B,233000 ;MAGIC NO. FOR ADDRESS OF FIX, HO HO.
03800 PUSHJ P,EMINST
03900 POP P,B ;GET LOCATION IN VARIABLE AREA OF THE STEPS-TO-SKIP COUNTER.
04000 MOVSI C,(<MOVNM>) ;AND EMIT INSTR. TO STORE NEGATIVE OF COUNT THERE.
04100 PUSHJ P,EMINST
04200 PUSHJ P,CINS6 ;NOW COMPILE CALL ON UNIT GENERATOR.
04300 POP P,A ;RECOVER LOC. OF THE JRST UNDER THE AOSGE.
04400 MOVEI B,.FXBTS ;EMIT FIXUP TO MAKE IT POINT HERE (I.E., AFTER
04500 PUSHJ P,EMCD ; END OF U.G. CALL).
04600 JRST CINS5 ;ALL DONE.
00100 ;; THE WONDERFUL, WINNING LOADER.
00200
00300 R←←1
00400 I←←2
00500 V←←3
00600
00700 LOADER: MOVE R,JOBFF ;R-TIME CODE RELOCATION CONST.
00800 HRRZ I,RLOC ;
00900 ADD I,R ;I-TIME CONST.
01000 HRRZ V,ILOC
01100 ADD V,I ;VARIABLE RELOC. CONST.
01200 MOVE T3,V
01300 ADD T3,VLOC ;PROGRAM BREAK.
01400 HRRZM T3,JOBFF
01500 HRLM T3,JOBSA ;MAKE SURE IT TAKES.
01600 HRL A,R ;ZERO THE PROGRAM AREA.
01700 HRRI A,1(R)
01800 SETZM (R)
01900 BLT A,-1(T3)
02000 MOVEI H,0 ;START WITH R-TIME CODE.
02100 LD1: ADDI H,1 ;GO TO NEXT CHAIN OF BUFFERS.
02200 CAILE H,3 ;ALL DONE ?
02300 POPJ P, ;YES.
02400 PUSH P,[LDL1] ;FAKE UP A RETURN TO LDL1.
02500 MOVE C,(H) ;INIT. THE CURRENT LOC. COUNTER.
02600 SKIPA F,FCBUF-1(H) ;PTR. TO FIRST BUF. OF CHAIN.
02700 LD2: HRRZ F,(F) ;PTR. TO NEXT BUF. OF CHAIN.
02800 HRRZ E,F ;SET UP BYTE PTR. TO RELOC. BITS.
02900 HRLI E,200
03000 HRRZI D,LOBUFS/12+2(F) ;PTR. TO DATA IN BUF.
03100 HRLI D,-<LOBUFS-LOBUFS/12-2> ;WORD COUNT.
03200 LDGW: AOBJP D,LD2 ;WORD COUNT EXHAUSTED ?
03300 MOVE (D) ;NO. PICK UP NEXT DATA WORD.
03400 ILDB A,E ;FIRST 2 REL. BITS.
03500 ILDB B,E ;LAST 2.
03600 POPJ P,
03700 LDL: PUSHJ P,LDGW ;GET NEXT WORD FROM BUFFER.
03800 LDL1: JUMPE A,LDF1 ;NO REL. GIVEN; MAY BE A FIXUP.
03900 JUMPE B,LDRST ;IF NEITHER HALF, THEN IT'S A RESET.
04000 PUSH P,CLD3 ;ANOTHER FAKE RETURN ADDRESS.
04100 LDRL1: TRNE B,1 ;RELOCATE RIGHT HALF ?
04200 ADD (A) ;YES.
04300 TRNN B,2 ;LEFT HALF ?
04400 POPJ P, ;NO.
04500 MOVSS (A)
04600 ADD (A)
04700 MOVSS (A)
04800 POPJ P,
04900 LD3: ADDM (C) ;PUT IN CORE.
05000 CLDL: AOJA C,LDL ;GET ANOTHER.
00100 ;; MORE LOADER (BUT NOT MUCH MORE, YOU WILL NOTICE !).
00200
00300 LDF1:
00400 CLD3: JUMPE B,LD3 ;PERHAPS NOT A FIXUP.
00500 JUMPE LD1 ;IT MIGHT EVEN BE AN END MARK.
00600 LDB T3,[POINT 2,0,15] ;A FIXUP. GET REL. BITS FOR PTR.
00700 DPB T3,[POINT 5,0,17]
00800 PUSH P,0
00900 JUMPG LDF2 ;IS VALUE OF FIXUP TO BE FOUND IN BUFFER ?
01000 PUSHJ P,LDGW ;YES. GET IT.
01100 PUSHJ P,LDRL1 ;PERFORM ANY INDICATED RELOCATION ON IT.
01200 SKIPA T3,0 ;MOVE RELOCATED VALUE INTO T3.
01300 LDF2: MOVE T3,C ;VALUE IS CURRENT LOCATION.
01400 POP P,0 ;BRING BACK THE POINTER WORD.
01500 TLNE SWAPBT ;SHOULD WE EXCHANGE HALVES OF THE VALUE ?
01600 MOVSS T3 ;YES.
01700 TLNE RRFXBT ;SHOULD WE REPLACE THE RIGHT HALF OF THE LOCATION ?
01800 HRRM T3,@0 ;YES. SEE THE POINTER RELOCATION HAPPEN AUTOMATICALLY !!
01900 TLNE LRFXBT ;REPLACE THE LEFT HALF ?
02000 HLLM T3,@0 ;YES.
02100 TLNN LRFXBT+RRFXBT ;IF NEITHER HALF REPLACED, THEN
02200 ADDM T3,@0 ;IT'S AN ADDITIVE FIXUP.
02300 JRST LDL ;BACK TO MAIN LOOP.
02400
02500 LDRST: HALT ;THE FEATURE YOU HAVE REQUESTED ...
02600
02700
00100 DARR: PUSH P,[0] ;DEFINE SOME ARRAYS.
00200 DARR1: PUSHJ P,GETNAM ;SCAN NAME.
00300 XWD DF,SWVBT ;TYPE PARAMETER TO GETNAM.
00400 PUSH P,A ;STACK PTR. TO ENTRY.
00500 PUSHJ P,SCAN ;LOOK FOR COMMA.
00600 CAMN A,COMMAV ;IS IT ONE ?
00700 JRST DARR1 ;YES. GET MORE NAMES.
00800 CAME A,LPARV ;NO. SHOULD BE A (.
00900 ERROR(MISSING LEFT PAREN.)
01000 PUSHJ P,SCAN ;GET THE DIMENSION.
01100 TLNN A,NUMFLG ;MAKE SURE IT'S A NUMBER.
01200 ERROR(IMPROPER DIMENSION)
01300 MOVE B,(A) ;GET VALUE.
01400 TLNN A,FIXFLG ;IS IT FLOATING ?
01500 FIX B,233000
01600 DARR3: AOS JOBFF ;GET FREE STORAGE PTR.
01700 POP P,T ;PTR. TO NAME IN TABLE...
01800 JUMPE T,DARR2 ;UNLESS ITS THE MARK.
01900 JUMPG T,DARR4 ;WAS IT PREVIOUSLY DEFINED ?
02000 HRRZ T1,(T) ;YES. GET ITS BASE ADDRESS.
02100 CAMG B,-1(T1) ;IS NEW DIMENSION > OLD ?
02200 JRST DARR3 ;NO. LEAVE OLD DEFINITION ALONE.
02300 DARR4: AOS A,JOBFF ;INCREMENT FREE STG. PTR. AGAIN.
02400 HRRM A,(T) ;PUT IN SYM. TABLE.
02500 MOVEM B,-1(A) ;PUT DIMENSION IN -1TH ELEMENT.
02600 HRLI A,INSXR ;PUT GOOD INDEX FIELD IN A...
02700 MOVEM A,-2(A) ;PUT PTR. TO ARRAY WITH INDEX IN AR[-2]
02800 ADDM B,JOBFF ;INCREMENT IT.
02900 JRST DARR3 ;TRY FOR ANOTHER.
03000 DARR2: PUSHJ P,SCAN ;GET THE ).
03100 CAME A,RPARV
03200 ERROR(MISSING RIGHT PAREN.)
03300 PUSHJ P,SCAN
03400 CAMN A,COMMAV ;A COMMA ?
03500 JRST DARR ;YES. START OVER AGAIN.
03600 HRRZ JOBSYM ;LET'S FIND OUT IF WE'VE LOST...
03700 CAMG JOBFF ;IS TOP STILL ABOVE BOTTOM ?
03800 ERROR(STORAGE IS FULL)
03900 HRRZ JOBFF
04000 HRLM JOBSA
04100 JRST STATL1
00100 ; HERE IS THE OUTER LOOP OF THE WHOLE SYSTEM.
00200
00300 CHOWN1: PUSHJ P,INTER1 ;INTERPRET STATEMENT.
00400 SCHOWN: PUSHJ P,SMSC1 ;GET FIRST NON-SEMICOLON.
00500 CHOWN: CAMN A,PLAYV ;IS IT A 'PLAY' SECTION ?
00600 JRST PLAY1 ;YES.
00700 CAMN A,ALTV ;IS IT AN ALT MODE ?
00800 JRST COMMND ;YES. A COMMAND FOLLOWS.
00900 CAME A, COMPV ;A 'COMPILE' SECTION ?
01000 JRST CHOWN1 ;NO. JUST A STATEMENT.
01100 PUSHJ P,SCOMP ;INIT. THE COMPILER.
01200 PUSHJ P,SSTATL ;COMPILE A STATEMENT LIST.
01300 PUSHJ P,LOADER ;LOAD THE CODE.
01400 JRST SCHOWN ;DONE WITH THAT SECTION.
01500
01600 PLAY1: PUSHJ P,GSBUF ;WE'RE GOING TO PLAY; GET SAMPLE BUFFER.
01700 AOS SBCNT
01800 PLAY1A: SETZM TIME# ;T←0.
01900 SETZM RQPTR# ;RUN QUEUE IS EMPTY.
02000 SETZM MAXSMP# ;INIT. THE MAXIMUM SAMPLE REMEMBERER.
02100 PLAY2: PUSHJ P,SMSC1 ;SCAN A NON-SEMICOLON.
02200 CAME A,FINV ;A 'FINISH ' ?
02300 CAMN A,PLAYV ;... OR A 'PLAY' ?
02400 JRST PTERM ;YES. END OF SECTION.
02500 TLNE A,INSBIT ;AN INSTRUMENT NAME ?
02600 JRST PINS ;YES. A NOTE STATEMENT.
02700 PUSH P,[EXP PLAY2] ;NO. INTERPRET THE STATEMENT.
02800 INTER1: CAME A,INSV
02900 CAMN A,FUNV
03000 ERROR (ILLEGAL 'PLAY' STATEMENT)
03100 PUSHJ P,SCOMPA ;IT MUST BE A RANDOM STATEMENT.
03200 ;PREPARE TO INTERPRET IT BY INITIALIZING
03300 ;THE COMPILER.
03400 PUSHJ P,STAT ;COMPILE THE STATEMENT.
03500
03600 INTERP: MOVE A,[JRST INTER2] ;PREPARE TO EXECUTE TEMPORARY
03700 MOVEI B,0 ;CODE (I.E,RUN IN INTERPRET MODE).
03800 PUSHJ P,EMICDI ;EMIT RETURN INSTR. AT END OF CODE.
03900 PUSHJ P,ENDP1 ;CLEAN UP COMPILER.
04000 PUSH P,JOBFF ;SAVE FREE STG. PTR.
04100 PUSHJ P,LOADER ;LOAD THE TEMPORARY CODE.
04200 MOVEM P,PSV1# ;SAVE IT.
04300 MOVEM FL,FLSV1#
04400 MOVE 17,P ;PTR. FOR (UGH! BLETCH!) FOOTRAN PGMS.
04500 JRST @(P) ;EXECUTE IT.
04600 INTER2: MOVE P,PSV1 ;RESTORE PUSHDOWN POINTER.
04700 MOVE FL,FLSV1
04800 POP P,0 ;RETRIEVE OLD STG. PTR.
04900 HRRZM JOBFF ;FLUSH THE TEMP. CODE.
05000 HRLM JOBSA ;(IT HAS TO GO HERE TOO.)
05100 POPJ P, ;LOOK, MA, I'M AN INTERPRETER !!
05200
00100 ;THIS CODE READS A NOTE STATEMENT, INITIALIZES THE
00200 ; INSTRUMENT, AND GETS IT TURNED ON AT THE RIGHT TIME.
00300
00400 PINS: MOVE A,(A) ;GET STARTING ADDRESSES FOR INSTRUMENT.
00500 PUSH P,(A) ;SAVE THEM.
00600 MOVEI PBASE ;PREPARE TO FILL THE P ARRAY WITH
00700 MOVEM PPTR1# ;THE PARAMETERS TO THE INSTR.
00800 PUSHJ P,SCOMPA ;INIT. COMPLR. FOR POSSIBLE EXPRESSIONS.
00900 MOVE NCHNS ;GET NO. OF OUTPUT CHANNELS.
01000 TLNE -1 ;IS IT FLOATING ?
01100 FIX 233000
01200 PINS2: MOVEM NCHNS
01300 PUSH P,NUMBUC ;SAVE CURRENT STATE OF NUMBER
01400 PUSH P,JOBFF ;BUCKET AND CORE TOP.
01500 JRST PINSL ;INIT. THE COMPILER.
01600
01700
01800 PINSL1: CAMN A,COMMAV ;OPTIONAL COMMA BETWEEN PARAMS...
01900 PINSL: PUSHJ P,SCAN
02000 AOS PPTR1 ;INCREMENT P-ARRAY POINTER.
02100 CAMN A,COMMAV ;A COMMA HERE MEANS MISSING
02200 JRST PINSL ;PARAM., SO DON'T CHANGE.
02300 CAMN A,SEMICV ;SEMICOLON ?
02400 JRST PINSB ;YES, END OF PARAMETERS.
02500 PUSHJ P,EXPR ;PARAMETER MAY BE EXPRESSION.
02600 PUSHJ P,GPONDER ;GET OPERAND POINTER FOR THE EXPR...
02700 TLNE T,SIACBT ;IS VALUE OF EXPR AN AC SYMBOL ?
02800 JRST PINS1 ;YES. IT HAS TO BE CALCULATED.
02900 MOVE C,(T) ;PICK UP ITS VALUE.
03000 MOVEM C,@PPTR1 ; SO PUT ITS VALUE IN P-ARRAY NOW.
03100 JRST PINSL1
03200 PINS1: PUSH P,A ;EXPR. GENERATED SOME CODE, EVIDENTLY.
03300 MOVE A,T ;EMIT AN INSTRUCTION TO STORE THE
03400 MOVE B,PPTR1 ;RESULTANT VALUE IN THE P-ARRAY.
03500 MOVE C,[MOVEM EMICDI]
03600 PUSHJ P,EMINST ;THE CODE WILL GET EXECUTED
03700 PUSHJ P,INTERP ; RIGHT NOW.
03800 PUSHJ P,SCOMPA
03900 POP P,A
04000 JRST PINSL1 ;BACK FOR MORE PARAMS.
00100 ;; MORE OF PINS.
00200
00300 PINSB: POP OSP,JOBSYM ;FLUSH COMPLR. OUTPUT BUFFERS.
00400 POP P,0 ;RECOVER OLD CORE TOP.
00500 MOVEM JOBFF ;RESET THINGS TO FORGET
00600 HRLM JOBSA ;ABOUT THE NUMBERS WE DEFINED WHILE
00700 POP P,NUMBUC ;SCANNING NOTE PARAMETERS.
00800 MOVE A,SRATE ;GET NO. OF SAMPLES/SEC.
00900 FDVR A,TIMESC ;DIVIDE BY BEATS/SEC.
01000 MOVE B,PBASE+1 ;GET STARTING TIME FOR NOTE.
01100 FMPR B,A ;CONVERT TO SAMPLES.
01200 FADR B,[0.5]
01300 FIX B,233000
01400 MOVEM B,RQ1 ;PLACE AT BOTTOM OF RUN QUEUE.
01500 FMPR A,PBASE+2 ;GET DURATION OF NOTE IN SAMPLES.
01600 FADR A,[0.5]
01700 FIX A,233000
01800 ADD A,B ;CALC. ENDING TIME OF NOTE.
01900 PUSH P,A ;SAVE SAME.
02000 PUSHJ P,PLAYIT ;PLAY UP TO STARTING TIME OF NOTE.
02100 PLYON: AOS A,RQPTR ;NOW TURN INSTRUMENT ON.
02200 POP P,RQ1(A) ;PUT ENDING TIME IN RUNQUEUE, COL. ONE.
02300 POP P,T ;GET STARTING ADDR. OF INSTRUMENT.
02400 HLRZM T,RQ2(A) ;PLACE IN RUN QUEUE, COL. TWO.
02500 PUSHJ P,(T) ;EXECUTE THE I-TIME CODE.
02600 JRST PLAY2 ;BACK FOR MORE NOTE STATEMENTS.
02700
02800 PTERM: PUSH P,A ;HERE AT A 'PLAY' OR 'FINISH'.
02900 MOVSI 200000
03000 MOVEM RQ1 ;SET UP FAKE STARTING TIME.
03100 PUSHJ P,PLAYIT ;FLUSH THE RUN QUEUE.
03200 POP P,A
03300 CAMN A,PLAYV ;WAS IT A 'PLAY' THAT WE SAW ?
03400 JRST PLAY1A ;YES. START NEW SECTION.
03500 PUSHJ P,OSBUF ;NO, A 'FINISH'. EMPTY THE
03600 JRST SCHOWN ;SAMPLE BUFFER AND START OVER.
00100 ;; THIS ROUTINE GENERATES SAMPLES BY CALLING THE
00200 ;; INSTRUMENTS IN THE RUN QUEUE UNTIL IT IS TIME
00300 ;; TO TURN ON THE INSTRUMENT WHOSE STARTING TIME IS
00400 ;; IN THE ZEROTH LOCATION OF THE QUEUE, WHEN IT RETURNS.
00500 ;; INSTRUMENTS ARE TURNED OFF AS REQUIRED.
00600
00700 PLAYIT: MOVE A,RQPTR ;SEARCH FOR EARLIEST TIME IN QUEUE.
00800 PLYT2: MOVEM A,PTMP# ;SAVE ITS LOCATION.
00900 SKIPA H,RQ1(A) ;PICK IT UP.
01000 CAMG H,RQ1(A) ;A NEW MINIMUM ?
01100 SOJGE A,.-1 ;NO.
01200 JUMPGE A,PLYT2 ;YES.
01300 PLYT1: CAMN H,[XWD 200000,0] ;MIN. FOUND. IS IT THE TERMINATION
01400 POPJ P, ; MARK ? IF YES, THEN RETURN.
01500 SUB H,TIME ;IT'S NOT . CALC. DISTANCE IN FUTURE.
01600 JUMPLE H,PLYT3 ;IF NOT IN FUTURE, FORGET IT.
01700 ADDM H,TIME ;MOVE TIME TO NEW VALUE.
01800 PLYT4: SKIPE OSP,RQPTR ;CYCLE THRU RUNNING INSTRS., IF ANY.
01900 PUSHJ P,@RQ2(OSP) ;CALL AN INSTR.
02000 SOJG OSP,.-1 ;CALL THEM ALL.
02100 MOVEI F,1 ;START WITH CHANNEL 1.
02200 PLYT5: SOSG SBCNT ;COUNT SAMPLE BUFFER COUNTER.
02300 PUSHJ P,FSBUF ;FLUSH FULL BUFFER.
02400 MOVEI B,0 ;PICK UP NEXT CHANNEL'S SAMPLE, AND
02500 EXCH B,OUTA-1(F) ; ZERO THE LOCATION.
02600 FAD B,[0.5] ;ROUND TO NEAREST INTEGER.
02700 FIX B,233000 ;A. KOTOK SHOULD HAVE DONE THIS.
02800 MOVM A,B ;GET MAGNITUDE...
02900 CAMLE A,MAXSMP ;IS THIS SAMPLE THE BIGGEST YET ?
03000 MOVEM A,MAXSMP ;YUP.
03100 IDPB B,SBPTR ;PLACE IT IN SAMPLE BUFFER.
03200 CAMGE F,NCHNS ;LAST CHANNEL ?
03300 AOJA F,PLYT5 ;NO. GET OTHER CHANNELS.
03400 SOJG H,PLYT4 ;GENERATE REST OF SAMPLES.
03500
03600 PLYT3: SKIPG A,PTMP ;GET PTR. TO NEXT INSTR. OFF OR ON.
03700 POPJ P, ;TIME TO TURN ONE ON.
03800 SOS B,RQPTR ;REMOVE INSTR. FROM QUEUE.
03900 MOVE RQ1+1(B) ;MOVE TOP ENTRY DOWN INTO VACANT
04000 MOVEM RQ1(A) ;SPOT.
04100 MOVE RQ2+1(B)
04200 MOVEM RQ2(A)
04300 JRST PLAYIT ;GO PLAY TILL NEXT EVENT.
04400
00100 ;; RANDOM ROUTINES TO HANDLE THE SAMPLE OUTPUT BUFFER.
00200
00300 GSBUF: HRRZ T,JOBSYM ;GET A SAMPLE BUFFER.
00400 SUB T,JOBFF ;HOW MUCH ROOM IS LEFT ?
00500 SUBI T,4*LOBUFS ;(ALLOWING ROOM FOR CODE BUFFERS)
00600 SKIPN BIGBIT ;SETS LSBUF TO 1024 IF EITHER BIGBIT OR RCDFLG!
00700 SKIPE RCDFLG
00800 SKIPA
00900 JRST GSBUF1 ;1023 IS FOR DEFERRED LONGPLAY
01000 CAIGE T,=1024 ;1024 IS FOR IMMEDIATE LONGPLAY WITH 'PLAY'
01100 ERROR (ADD 1K OF CORE!)
01200 MOVEI T,=1023
01300 SKIPGE RCDFLG ;IS IT POSITIVE OR ZERO?
01400 MOVEI T,=1024 ;NO, RCDFLG←-1; IS FOR IMMEDIATE LONGPLAY
01500 GSBUF1: MOVEM T,LSBUF ;PUT AWAY.
01600 MOVNS T
01700 PUSHJ P,GFS ;GRAB ENOUGH FREE STORAGE...
01800 HRRZM T,SBBOTT# ;SAVE PTR. TO BUFFER.
01900 FSBUF2: HRLI T,441400 ;MAKE BYTE POINTER.
02000 SKIPE BIGBIT ;IS IT 18 BIT?
02100 HRLI T,442200 ;YES. RESET BYTE SIZE
02200 MOVEM T,SBPTR# ;
02300 MOVE T,LSBUF ;GET LENGTH OF BUFFER.
02400 ASH T,1 ;SAMPLE CT = LSBUF *2 FOR 18 BIT
02500 SKIPN BIGBIT ;IS IT 18 BIT?
02600 ADD T,LSBUF ;NO, MAKE * 3.
02700 MOVEM T,SBCNT#
02800 POPJ P,
02900
03000 OSBUF: HRRZ LSBUF ;THROW OUT SAMPLE BUFFER...
03100 ADDM JOBSYM
03200 MOVEI 0
03300 SKIPA T,SBCNT
03400 IDPB 0,SBPTR
03500 SOJG T,.-1
03600 JRST FSBUF
03700
03800 SMPOUT: MOVE SBBOTT
03900 MOVEM IBOTT
04000 ; MAR 16,71 MOVE BIGBIT
04100 ; MAR 16,71 MOVEM IBIT#
04200 JSA 16, SMPLS ;CALL WRITING ROUTINE
04300 JUMP LSBUF
04400 JUMP SBCNT
04500 IBOTT: 0
04600 JUMP MAXSMP
04700 ; MAR 16,71 JUMP IBIT
04800 JUMP BIGBIT
04900 JUMP RCDFLG ;RCDFLG←-1 WRITES ONE LONG .DMD FILE 6/71
05000 SKIPN BIGBIT
05100 SKIPE RCDFLG ;RCDFLG ON?
05200 SKIPE DOPLAY ;PLAY ANYWAY?
05300 JRST FSBUF1 ;GO TO PLAY
05400 JRST FSBF2A ;DOESN'T PLAY
05500
05600
05700 FSBUF: SKIPN BIGBIT
05800 SKIPE RCDFLG# ;OUTPUT TO DISC?
05900 JRST SMPOUT
06000 FSBUF1: HRR SBBOTT ;CALCULATE NEGATIVE WORD COUNT.
06100 SUB SBPTR
06200 SUBI 1 ;PREVENT 0 WORD COUNTS.
06300 HRRZ T,SBBOTT ;GET BOTTOM OF BUFFER....
06400 HRLI -1(T) ; MINUS ONE.
06500 MOVSM OUTWC ;PUT IOWD IN RIGHT PLACE.
06600 PUSHJ P,FSBF1
06700 JRST FSBF2
06800 FSBF1: MOVE NCHNS ;NO. OF OUTPUT CHANNELS.
06900 TLNE -1
07000 FIX 233000
07100 FSBF3: SUBI 1
07200 DPB [POINT 2,OUTBIT,26] ;STEREO OR MONO MODE.
07300 MOVM SPEED
07400 TLNE -1 ;FIX IF NECESSARY.
07500 FIX 233000
07600 FSBF4: DPB [POINT 3,OUTBIT,32]
07700 L1: INIT ADCHN,17
07800 SIXBIT /AD/
07900 0
08000 ERROR (A-D UNAVAILABLE.)
08100 POPJ P,
08200
08300 XGP: MOVSI 'XGP' ;TO AVOID XGP CONFILICT
08400 DEVUSE 0,
08500 HLRZ 0,0
08600 CAIN 400000
08700 POPJ P,
08800 INIT 16,17
08900 SIXBIT .XGP.
09000 0
09100 JRST XGP ;was JRA 16,2(16)
09200 POPJ P,
09300 FSBF2: PUSHJ P,XGP ;GO INIT THE XGP
09400 OUTPUT ADCHN,OUTWC ;EMPTY THE BUFFER.
09500 RELEAS ADCHN,
09600 RELEASE 16,
09700 FSBF2A: MOVE T,SBBOTT ;NOW SET UP POINTERS AGAIN.
09800 JRST FSBUF2
09900
10000 OUTWC: 0
10100 3650 ;MAGIC BITS FOR 136.
10200 OUTBIT: 4000 ;BITS FOR A-D.
10300 BLOCK 2
00100 ;; ERROR HANDLING(?) ROUTINES.
00200
00300 ERR1: 0 ;HERE FROM UUO TRAP.
00400 TLNE FL,ERRFLG ;IN ERROR SKIPPING MODE ?
00500 JRST 2,@ERR1 ;YES.
00600 MOVEM 17,ERSVAC+17 ;NO. SAVE ACS.
00700 MOVEI 17,ERSVAC
00800 BLT 17,ERSVAC+16
00900 JSR ERR2 ;PRINT MESSAGE.
01000 MOVSI 17,ERSVAC ;RESTORE AC'S.
01100 BLT 17,17
01200 ERRX: TLO FL,ERRFLG ;ENTER ERROR-SKIPPING MODE.
01300 RELEAS TTY,0
01400 RELEAS DT,0
01500 PUSHJ P,SETUP1
01600 JRST GOB
01700 JRST 2,@ERR1 ;TRY TO CONTINUE (HO, HO.).
01800
01900 ERSVAC: BLOCK 20
02000
02100 ERR2: 0 ;ERROR MESSAGE PRINTER.
02200 HRRZI [ASCIZ /
02300 $$$ ERROR: /]
02400 JSR TXTOUT
02500 HRRZ 40
02600 JSR TXTOUT
02700 HRRZI [ASCIZ /
02800 /]
02900 JSR TXTOUT
03000 MOVE A,ISCP
03100 MOVE B,A
03200 MOVE C,B
03300 ERR2B: ILDB A
03400 CAIE 15
03500 JRST ERR2A
03600 MOVE C,B
03700 MOVE B,A
03800 ERR2A: CAME A,SCP
03900 JRST ERR2B
04000 JRST ERR2D
04100 ERR2C: SOSGE TOB+2
04200 OUTPUT TTY,0
04300 IDPB TOB+1
04400 ERR2D: ILDB C
04500 CAME C,SCP
04600 JRST ERR2C
04700 SKIPN SNCHR
04800 IDPB TOB+1
04900 OUTPUT TTY,0
05000 JRST @ERR2
05100
05200
00100
00200 SYMSCH: MOVEI T,6 ;LOOK UP EXTERNAL SYMBOL.
00300 MOVE [POINT 6,ACCUM,5] ;PREPARE TO CONVERT TO
00400 MOVEI B,0
00500 SYMS1: ILDB A,0 ;RADIX 50.
00600 JUMPE A,SYMS4
00700 CAIN A,16
00800 MOVEI A,73
00900 CAIG A,5
01000 ADDI A,70
01100 CAIGE A,32
01200 ADDI A,7
01300 IMULI B,50
01400 ADDI B,-26(A)
01500 SOJG T,SYMS1
01600 SYMS4: TLO B,40000
01700 MOVE A,116
01800 SYMS3: AOBJP A,SYMS2
01900 CAME B,-1(A)
02000 AOBJN A,SYMS3
02100 SYMS2: SKIPL A
02200 SKIPA A,[EXP NX]
02300 HRRZ A,(A)
02400 POPJ P,
02500
02600 NX: 0
02700 ERROR (MISSING EXTERNAL FUNCTION)
02800 JRST INTER2
02900
03000
03100 INTERNAL RDNUM,MESS,PNUM
03200
03300 EXTERNAL JOBDDT;
03400 PNUM: 0
03500 MOVE P,JOBFF
03600 SKIPGE A,@(RA)
03700 OUTCHR ["-"]
03800 MOVMS A
03900 PUSHJ P,DECPNT
04000 OUTPUT TTY,0
04100 JRA RA,1(RA)
00100 RDNUM: 0 ;NUMBER READER FOR FOOTRAN ROUTINES.
00200 MOVE P,JOBFF ;GET TEMP. PDL
00300 EXCH FL,FLSV1
00400 RDNUM1: TLO FL,SNUMF1
00500 PUSHJ P,SCAN
00600 CAMN A,MINV ;A MINUS SIGN ?
00700 TLOA FL,MINFLG ;YES. SET FLAG AND LOOP BACK.
00800 TLNN A,NUMFLG ;IT IS A NUMBER, ISN'T IT ?
00900 JRST RDNUM1 ;NO. IGNORE IT.
01000 TLZE FL,MINFLG ;YES. HAVE WE SEEN A MINUS LATELY ?
01100 MOVNS C ;YES.
01200 MOVEM C,@(RA) ;PUT VALUE INTO PARAMETER.
01300 EXCH FL,FLSV1
01400 JRA RA,1(RA) ;RETURN TO (UGH ! BLETCH !) FOOTRAN.
01500 MESS: 0 ;MESSAGE PRINTER FOR FOOTRAN ROUTINES.
01600 HRRZ (RA) ;GET LOC. OF MESSAGE.
01700 CALLI 3
01800 JRA RA,1(RA)
01900
02000 FOOPRT: 0
02100 MOVM A,@(RA)
02200 TLNE A,777000
02300 FIX A,233000
02400 PUSHJ P,DECPNT
02500 OUTPUT TTY,0
02600 JRST 1(RA)
02700
02800 COMMND: MOVEI [ASCII /$/]
02900 CALLI 3
03000 PUSHJ P,SCANNS ;GET COMMAND.
03100 JUMPL A,COMND1
03200 MOVE ACCUM
03300 MOVE 1,ACCUM+1
03400 LSHC 6
03500 CAMN [SIXBIT /RESET/]
03600 JRST REST1
03700 CAMN [SIXBIT /PRINT/]
03800 JRST CPNT ;A 'PRINT' COMMAND.
03900 CAMN [SIXBIT /P/]
04000 JRST CPLX
04100 CAMN [SIXBIT /DDT/]
04200 JRST @JOBDDT
04300 COMND1: MOVEI [ASCIZ /?? /]
04400 CALLI 3
04500 JRST SCHOWN
04600 CPLX: PUSHJ P,CGNUM ;GET FOLLOWING NUMBER, IF ANY.
04700 MOVEI T,1 ;NO NUMBER. TAKE AS 1.
04800 CPLAY:
04900 ; SKIPE DSKFLG ;DISK OUTPUT ?
05000 ; JRST DSKPLA ;YES.
05100 PUSHJ P,FSBF1 ;SET UP FOR D-A OUTPUT.
05200 PUSHJ P,XGP
05300 OUTPUT ADCHN,OUTWC
05400 SOJG T,CPLAY ;REPEAT AS INDICATED BY ARGUMENT.
05500 RELEAS ADCHN,
05600 RELEASE 16,
05700 JRST SCHOWN
05800
00100 REST1: MOVEI TEMPSY
00200 MOVEM BUCTBL
00300 JRST GO
00400
00500 ;MORE COMMAND ROUTINES.
00600
00700 CPNT: PUSHJ P,SCOMPA ;INIT. THE COMPILER.
00800 PUSH OSP,[XWD VRBLBT,[XWD VRBLBT,CPNTX#]] ;PUT FAKE VARIABLE IN STACK.
00900 PUSHJ P,ASTMT1 ;COMPILE RIGHT PART OF AN ASSIGNENT STATEMENT.
01000 PUSHJ P,INTERP ;EXECUTE THE CODE.
01100 MOVM A,CPNTX ;GET ITS VALUE.
01200 TLNE A,377000 ;ASSUMING ITS >0, IS IT FLOATING?
01300 FIX A,233000
01400 CPNT2: PUSHJ P,DECPNT ;PRINT IT.
01500 OUTPUT TTY,0
01600 POP P,A ;GET THING WHICH TERMINATED EXPR. (LEFT ON STACK BY ASTMT1).
01700 CAMN A,SEMICV ;A SEMICOLON ?
01800 JRST SCHOWN ;YES. FORGET IT.
01900 JRST CHOWN ;NO. LOOK AT IT.
02000
02100
02200 CGNUM: TLO FL,SNUMF1 ;DONT PUT NO.'S IN TABLE.
02300 PUSHJ P,SCAN ;LOOK FOR (OPTIONAL) NUMERIC ARGUMENT.
02400 TLNN A,NUMFLG ;IS THERE ONE ?
02500 POPJ P, ;NO.
02600 MOVE T,C ;YES. GET VALUE.
02700 TLNN A,FIXFLG ;IS IT FLOATING ?
02800 FIX T,233000 ;NOT ANY MORE.
02900 CGNUM2: POP P,T1 ;GET RETURN ADDR.
03000 JRST 1(T1) ;SKIP ON RETURN.
03100 END GO